save url table on exit

breve.cabal

@@ -32,10 +32,10 @@ executable breve
   other-extensions:  OverloadedStrings
   build-depends:     base >=4.8 && <5.0,
                      warp, warp-tls, tls, blaze-html, blaze-markup,
-                     servant-server, servant, servant-blaze, http-api-data,
-                     wai, wai-extra, streaming-commons,
+                     servant-server, servant, servant-blaze,
+                     wai, wai-extra, streaming-commons, http-api-data,
                      transformers, mtl,
                      text, aeson, bytestring, binary,
                      hashtables, cryptohash, random,
-                     xdg-basedir, configurator, directory
+                     configurator, directory
   ghc-options:       -threaded -O2

src/Application.hs

@@ -5,6 +5,10 @@
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
+{-|
+This module contains the web application
+and API implementation of Breve.
+-}
 module Application where
 
 -- Breve modules
@@ -36,7 +40,7 @@ import GHC.TypeNats             (Nat)
 -- * Types
 
 -- | API successful reply
--- This is the reply returned by the API
+-- This is the reply returned by the JSON API
 -- handler when the url has been shortned
 -- successfully.
 data ApiReply = ApiReply
@@ -55,13 +59,25 @@ instance FromForm Url where
 
 -- | API spec
 --
--- Breve has three main components:
+-- Breve has two main components:
+--
 -- 1. the web app
--- 2. the JSON API
--- 3. the static files server
+-- 2. the JSON API itself
 type Breve = API :<|> App
 
 -- | Web app spec
+--
+-- +----------+------+----------------------+
+-- | path     | type | description          |
+-- +==========+======+======================+
+-- | /        | GET  | homepage             |
+-- +----------+------+----------------------+
+-- | /        | POST | upload a new url     |
+-- +----------+------+----------------------+
+-- | /static  | GET  | static assets        |
+-- +----------+------+----------------------+
+-- | /:name   | GET  | resolves a short url |
+-- +----------+------+----------------------+
 type App =
        Get '[HTML] Html
   :<|> "static" :> Raw
@@ -69,24 +85,28 @@ type App =
   :<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html
 
 -- | JSON API spec
+--
+-- +----------+------+----------------------+
+-- | path     | type | description          |
+-- +==========+======+======================+
+-- | /        | POST | upload a new url     |
+-- +----------+------+----------------------+
 type API =
   "api" :> ReqBody '[FormUrlEncoded] Url :> Post '[JSON] ApiReply
 
--- | Verb that encodes an HTTP 302 redirection
-type Redirect =
-  Verb 'GET 302 '[PlainText] Redirection
-
--- | Reply with Location redirect header
-type Redirection =
-  Headers '[Header "Location" Text] NoContent
-
-
 -- | Breve application
 --
 -- Breve takes as parameters the bind url and the urls table
 breve :: FilePath -> Url -> UrlTable -> Application
 breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table)
 
+-- | Empty application
+--
+-- This app does *nothing* but it's useful nonetheless:
+-- it will be used as a basis to run the 'forceSSL'
+-- middleware.
+emptyApp :: Application
+emptyApp = serve (Proxy :: Proxy EmptyAPI) emptyServer
 
 -- * Handlers
 
@@ -126,7 +146,7 @@ uploader bindUrl table url = do
   logStr ("Registered " <> url <> " -> " <> name)
   pure (done $ bindUrl <> name)
 
--- Takes a 'Url' via POST and returns
+-- | Takes a 'Url' via POST and returns
 -- the shortned one in an 'ApiReply' as JSON.
 api :: Url -> UrlTable -> Url -> Handler ApiReply
 api bindUrl table url = do
@@ -141,4 +161,12 @@ api bindUrl table url = do
 
 -- | Handy function to log to stdout
 logStr :: Text -> Handler ()
-logStr = liftIO . T.putStrLn
+logStr = liftIO . T.putStrLn . ("[breve] " <>)
+
+-- | Verb that encodes an HTTP 302 redirection
+type Redirect =
+  Verb 'GET 302 '[PlainText] Redirection
+
+-- | Reply with Location redirect header
+type Redirection =
+  Headers '[Header "Location" Text] NoContent

src/Breve/Generator.hs

@@ -1,8 +1,12 @@
+{-|
+This module implements the algorithm
+by which a URL is converted into a word.
+-}
 module Breve.Generator
-( nameHash
-, intHash
-, Name
+( Name
 , Url
+, nameHash
+, intHash
 ) where
 
 import Control.Monad.State
@@ -13,7 +17,10 @@ import Data.ByteString.Lazy   (fromStrict)
 import Data.Text              (Text, pack)
 import Data.Text.Encoding     (encodeUtf8)
 
+-- | A phonetic word associated to a URL
 type Name = Text
+
+-- | Any kind of URL
 type Url  = Text
 
 -- | Takes a random element of a list
@@ -32,6 +39,10 @@ word = pack <$> replicateM 10 letter where
 intHash :: Url -> Int
 intHash = decode . fromStrict . hash . encodeUtf8
 
--- | Assigns a unique name to the url
+-- | Assigns a unique name to the given URL
+--
+-- The result is a computation based on a RNG
+-- seeded by URL itself and is therefore
+-- deterministic.
 nameHash :: Url -> Name
 nameHash = evalState word . mkStdGen . intHash

src/Breve/Settings.hs

@@ -1,9 +1,18 @@
-module Breve.Settings where
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+This module defines the Breve configuration
+parser and application settings.
+-}
+module Breve.Settings
+( AppSettings(..)
+, createEmptyIfMissing
+, settings
+) where
 
 import Control.Monad                  (when)
 import System.Environment             (lookupEnv)
-import System.Environment.XDG.BaseDir
-import System.Directory                (doesFileExist)
+import System.Directory               (doesFileExist, getXdgDirectory, XdgDirectory(..))
 import Data.Text                      (Text, pack)
 import Data.Configurator
 import Data.Monoid
@@ -12,28 +21,29 @@ import Network.Wai.Handler.WarpTLS     (TLSSettings (..), tlsSettingsChain)
 import Network.TLS                    (Version (..))
 import Network.TLS.Extra              (ciphersuite_strong)
 
+-- | Breve settings
 data AppSettings = AppSettings
-  { bindHost    :: Text
-  , bindPort    :: Int
-  , bindUrl     :: Text
-  , urlTable    :: FilePath
-  , tlsSettings :: TLSSettings
+  { bindHost    :: Text         -- ^ the host to bind to
+  , bindPort    :: Int          -- ^ the port to bind to
+  , bindUrl     :: Text         -- ^ the url used to reach breve
+  , urlTable    :: FilePath     -- ^ path where to save the url table
+  , tlsSettings :: TLSSettings  -- ^ warp TLS settings
   }
 
-
+-- | Initialises a file if it doesn't exist
 createEmptyIfMissing :: FilePath -> IO ()
 createEmptyIfMissing file = do
   exists <- doesFileExist file
   when (not exists) (writeFile file "")
 
-
+-- | Configuration file parser
 settings :: Maybe FilePath -> IO AppSettings
 settings path = do
   configPath <- case path of
     Just path -> return path
-    Nothing   -> getUserConfigFile "breve" ""
+    Nothing   -> getXdgDirectory XdgConfig "breve"
 
-  urlsPath  <- getUserDataFile   "breve" ""
+  urlsPath  <- getXdgDirectory XdgData "breve"
 
   config  <- load [Required configPath]
   host    <- lookupDefault "localhost"                config "hostname"

src/Breve/UrlTable.hs

@@ -1,6 +1,11 @@
+{-|
+This modules defines the data structure used
+to store the URLs in memory and on disk.
+-}
 module Breve.UrlTable
 ( UrlTable
 , load
+, save
 , insert
 , extract
 ) where
@@ -12,16 +17,29 @@ import Control.Concurrent  (forkIO, threadDelay)
 import Text.Read           (readMaybe)
 import qualified Data.HashTable.IO as H
 
+-- | The hash table that stores URLs
 type UrlTable = H.CuckooHashTable Name Url
 
--- | Periodically write a url table to a file
+-- | Periodically save a 'UrlTable' to a file
 sync :: UrlTable -> FilePath -> IO ()
 sync table file = forever $ do
   threadDelay (round 3.0e8)
+  save table file
+
+-- | Writes a 'UrlTable' to a file
+--
+-- The table is stored in a text file
+-- as Haskell code for semplicity.
+save :: UrlTable -> FilePath -> IO ()
+save table file = do
   content <- show <$> H.toList table
   writeFile file content
+  putStrLn "\n[breve] url table synced."
 
--- | Load a url table from a file
+-- | Loads a URL table from a file
+--
+-- Once the file is loaded it will be synced
+-- periodically (every 5min) on the disk.
 load :: FilePath -> IO UrlTable
 load file = do
   content <- readFile file
@@ -31,11 +49,11 @@ load file = do
   forkIO (sync table file)
   return table
 
--- | Insert the url in a table and return the name
+-- | Insert the URL in a table and return the name
 insert :: UrlTable -> Url -> IO Name
 insert table url = H.insert table new url >> return new
   where new = nameHash url
 
--- | Lookup a table for the associated url
+-- | Lookup a table for the associated URL
 extract :: UrlTable -> Name -> IO (Maybe Url)
 extract = H.lookup

src/Main.hs

@@ -1,6 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 
+{-|
+This is the main module, which actually
+run the Breve webserver.
+-}
+module Main where
+
 -- Breve modules
 import Application
 import Breve.Settings
@@ -13,24 +19,27 @@ import Data.String     (IsString(..))
 import Data.Maybe      (listToMaybe)
 
 -- IO
+import Control.Monad      (when, void)
+import Control.Exception  as E 
+import Control.Concurrent (forkIO)
 import System.Environment (getArgs)
 import Data.Text.IO       as T
 
 -- Web server
 import Servant                      (Application)
-import Network.Wai.Handler.Warp     (defaultSettings, setPort, setHost)
+import Network.Wai.Handler.Warp     (run, defaultSettings, setPort, setHost)
 import Network.Wai.Handler.WarpTLS  (runTLS, TLSSettings)
 
 -- Middlewares
-import Network.Wai.Middleware.ForceSSL      (forceSSL)
 import Network.Wai.Middleware.RequestLogger (logStdout)
+import Network.Wai.Middleware.ForceSSL      (forceSSL)
 
 
 -- * Helpers
 
 -- | Runs Breve on the Warp webserver
-run :: AppSettings -> Application -> IO ()
-run (AppSettings{..}) =
+runApp :: AppSettings -> Application -> IO ()
+runApp (AppSettings{..}) =
   runTLS tlsSettings warpSettings
   where
     host = unpack bindHost
@@ -39,8 +48,8 @@ run (AppSettings{..}) =
 
 -- | Main
 --
--- Reads the config (given as the unique argument)
--- and runs the breve web app
+-- Reads the configuration (given as the unique cli argument),
+-- sets things accordingly and runs the webserver.
 main :: IO ()
 main = do
   configPath               <- fmap listToMaybe getArgs
@@ -48,10 +57,19 @@ main = do
   table                    <- load urlTable
   static                   <- getDataFileName "static/"
 
-  let
-    middlewares =
-      logStdout .
-      (if bindPort == 433 then forceSSL else id)
+  -- Redirect from HTTP to HTTPS when listening
+  -- on the standard port
+  when (bindPort == 443) $ void $
+    forkIO (run 80 $ forceSSL emptyApp)
 
+  -- Save the table just before exiting
+  let exit E.UserInterrupt = save table urlTable
+      exit e               = throwIO e
+
+  -- Middlewares are functions (Application -> Application).
+  -- We use one here to add requests
+  let middlewares = logStdout
+
+  handle exit $ do
     T.putStrLn ("Serving on " <> bindUrl)
-  run config (middlewares $ breve static bindUrl table)
+    runApp config (middlewares $ breve static bindUrl table)

src/Views.hs

@@ -1,16 +1,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 
+{-|
+This module contains the HTML pages used by the
+web application. These are all obtained by filling
+a single template with the page structure.
+-}
 module Views where
 
 import Data.Text                   (Text)
 import Text.Blaze.Html5            as H
 import Text.Blaze.Html5.Attributes as A
 
-done :: Text -> Html
-done url = template $ do
-  "here's your new link: "
-  a ! href (toValue url) $ (toHtml url)
-
+-- | The homepage
 index :: Html
 index = template $ do
   H.form ! method "POST" $ do
@@ -18,9 +19,22 @@ index = template $ do
     input ! type_ "text" ! name "url"
     input ! type_ "submit" ! value "go"
 
+-- | The page shown when a new url has been
+-- submitted successfully. Takes the resulting
+-- url as an argument.
+done :: Text -> Html
+done url = template $ do
+  "here's your new link: "
+  a ! href (toValue url) $ (toHtml url)
+
+-- | Displays a text message in the page center
 message :: Text -> Html
 message = template . toHtml
 
+-- | The main Breve template
+--
+-- Takes HTML code and embeds it in the
+-- inner page container.
 template :: Html -> Html
 template fill =
   docTypeHtml $ do