use a ReaderT to pass environment around

.gitignore

@@ -1,16 +1,3 @@
 dist
-cabal-dev
-*.o
-*.hi
-*.chi
-*.chs.h
-*.dyn_o
-*.dyn_hi
-.virtualenv
-.hpc
-.hsenv
-.cabal-sandbox/
-cabal.sandbox.config
-*.prof
-*.aux
-*.hp
+result
+default.nix

Setup.hs

@@ -1,2 +0,0 @@
-import Distribution.Simple
-main = defaultMain

breve.cabal

@@ -1,5 +1,5 @@
 name:                breve
-version:             0.4.5.1
+version:             0.5.0.0
 synopsis:            a url shortener
 description:
 
@@ -23,18 +23,21 @@ source-repository head
   location: https://maxwell.ydns.eu/git/rnhmjoj/breve
 
 executable breve
-  main-is:           Main.hs
-  hs-source-dirs:    src
-  default-language:  Haskell2010
-  other-modules:     Application, Views, Breve.Settings,
-                     Breve.Generator, Breve.UrlTable,
-                     Paths_breve
-  other-extensions:  OverloadedStrings
-  build-depends:     base >=4.8 && <5.0, warp, warp-tls, tls,
-                     Spock, Spock-core, blaze-html, http-types,
-                     wai, wai-middleware-static, wai-extra,
-                     transformers, mtl,
-                     text, aeson, bytestring, binary,
-                     hashtables, cryptohash, random,
-                     xdg-basedir, configurator, directory
-  ghc-options:       -threaded -O2
+  main-is:            Main.hs
+  hs-source-dirs:     src
+  default-language:   Haskell2010
+  other-modules:      Application, Views, Breve.Settings,
+                      Breve.Generator, Breve.UrlTable,
+                      Paths_breve
+  default-extensions: OverloadedStrings
+  other-extensions:   RecordWildCards, DeriveGeneric,
+                      DataKinds, KindSignatures, TypeOperators
+  build-depends:      base >=4.8 && <5.0,
+                      warp, warp-tls, tls, blaze-html,
+                      servant-server, servant-rawm, servant-blaze,
+                      wai, wai-extra, streaming-commons, http-api-data,
+
+                      mtl, text, aeson, bytestring, binary,
+                      hashtables, cryptohash, random,
+                      configurator, directory
+  ghc-options:        -threaded -O2 "-with-rtsopts=-N -qg"

src/Application.hs

@@ -1,79 +1,205 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE TypeOperators        #-}
+{-# LANGUAGE DeriveGeneric        #-}
+
+{-|
+This module contains the web application
+and API implementation of Breve.
+-}
 module Application where
 
+-- Breve modules
 import Breve.Generator
 import Breve.UrlTable
-import Paths_breve             (getDataFileName)
 import Views
 
-import Data.Monoid
-import Control.Monad.IO.Class  (liftIO)
-import Data.Aeson hiding       (json)
-import Data.Text               (Text)
-import qualified Data.Text.IO  as T
+-- Misc
+import Control.Monad.IO.Class   (liftIO)
+import Control.Monad.Reader     (ReaderT, runReaderT, asks)
+import qualified Data.Text.IO   as T
 
-import Web.Spock.Core
-import Network.HTTP.Types.Status
-import Network.Wai (Middleware)
-import Network.Wai.Middleware.Static
-import Network.Wai.Middleware.RequestLogger
+-- JSON conversion
+import Data.Text                (Text)
+import Data.Aeson               (ToJSON)
+import GHC.Generics             (Generic)
+
+-- HTML replies
+import Text.Blaze.Html5              (Html)
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
+
+-- API definition
+import Servant
+import Servant.HTML.Blaze       (HTML)
+import Servant.RawM             as R
+import Web.FormUrlEncoded       (FromForm(..), parseUnique)
 
 
-serveStatic :: FilePath -> Middleware
-serveStatic = staticPolicy . addBase
+-- * Types
+
+-- | Custom handler type with a
+-- reader environment
+type AppM = ReaderT AppEnv Handler
+
+-- | The environment associated
+-- to 'AppM'
+data AppEnv = AppEnv
+  { bindUrl   :: Text
+  , urlTable  :: UrlTable
+  , staticDir :: FilePath
+  }
+
+-- | API successful reply
+--
+-- This is the reply returned by the JSON API
+-- handler when the url has been shortned
+-- successfully.
+data ApiReply = ApiReply
+  { link     :: Url  -- ^ shortened url
+  , name     :: Name -- ^ just the name
+  , original :: Url  -- ^ original url
+  } deriving Generic
+
+instance ToJSON ApiReply
+
+-- | This type is just a wrapper around a 'Text'
+-- value. It's used to create a 'FromForm' instance
+-- for a 'Url'.
+newtype UrlForm = UrlForm Text
+
+instance FromForm UrlForm where
+  fromForm f = UrlForm <$> parseUnique "url" f
 
 
-reply :: Status -> Text -> ActionT IO ()
-reply code text = setStatus code >> render (message text)
+-- * Breve API
+
+-- | API spec
+--
+-- Breve has two main components:
+--
+-- 1. the web app
+-- 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" :> RawM
+  :<|> Capture "name" Name :> Redirect
+  :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html
+
+-- | JSON API spec
+--
+-- +----------+------+----------------------+
+-- | path     | type | description          |
+-- +==========+======+======================+
+-- | /api     | POST | upload a new url     |
+-- +----------+------+----------------------+
+type API =
+  "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply
+
+-- | Breve application
+--
+-- Notes:
+--
+-- * @api@ is an empty value that brings the type
+-- 'Breve' to the 'serve' function. If Haskell were
+-- depedently typed it would just be @serve Breve@
+--
+-- * hoistServer flattens the AppM monad stack
+-- in the breveServer definition
+breve :: AppEnv -> Application
+breve env = serve api (hoistServer api nt breveServer)
+  where api = Proxy :: Proxy Breve
+        nt x = runReaderT x env
+
+-- | 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
+
+-- | Breve server
+--
+-- This is just an ordered collection of handlers
+-- following the 'Breve' API spec.
+--
+-- Note: 'RawM' is  required because Servant doesn't
+-- allow the creation of a raw 'Application' from a
+-- monadic value.
+breveServer :: ServerT Breve AppM
+breveServer = api :<|> app
+  where app =  homepage
+          :<|> (R.serveDirectoryWebApp =<< asks staticDir)
+          :<|> resolver
+          :<|> uploader
+
+-- | Serves the homepage
+homepage :: AppM Html
+homepage = pure index
+
+-- | Resolves a 'Name' to the full 'Url'
+resolver :: Name -> AppM Redirection
+resolver name = do
+  table <- asks urlTable
+  url   <- liftIO (extract table name)
+  case url of
+    Nothing  ->
+      throwError $ err404 { errBody = renderHtml (message "404: not found") }
+    Just url -> do
+      logStr ("Resolved " <> name <> " -> " <> url)
+      pure (addHeader url NoContent)
 
 
-logStr :: Text -> ActionT IO ()
-logStr = liftIO . T.putStrLn
+-- | Takes a 'UrlForm' via POST
+-- and prints the shortned one
+uploader :: UrlForm -> AppM Html
+uploader (UrlForm url) = do
+  table <- asks urlTable
+  bind  <- asks bindUrl
+  name  <- liftIO (insert table url)
+  logStr ("Registered " <> url <> " -> " <> name)
+  pure (done $ bind <> name)
 
+-- | Takes a 'Url' via POST and returns
+-- the shortned one in an 'ApiReply' as JSON.
+api :: UrlForm -> AppM ApiReply
+api (UrlForm url) = do
+  table <- asks urlTable
+  bind  <- asks bindUrl
+  name  <- liftIO (insert table url)
+  logStr ("Registered " <> url <> " -> " <> name)
+  pure $ ApiReply { link     = (bind <> name)
+                  , name     = name
+                  , original = url
+                  }
 
-app :: Url -> UrlTable -> SpockT IO ()
-app url' table = do
-  static <- liftIO (getDataFileName "static/")
+-- * Misc
 
-  middleware (serveStatic static)
-  middleware logStdout
+-- | Handy function to log to stdout
+logStr :: Text -> AppM ()
+logStr = liftIO . T.putStrLn . ("[breve] " <>)
 
-  get "/" $ render index
+-- | Verb that encodes an HTTP 302 redirection
+type Redirect =
+  Verb 'GET 302 '[PlainText] Redirection
 
-  get var $ \name -> do
-    url <- liftIO (extract table name)
-    case url of
-      Nothing  -> reply status404 "404: does not exist"
-      Just url -> do
-        logStr ("Resolved " <> name <> " -> " <> url)
-        redirect url
-
-  post "/" $ do
-    url <- param "url"
-    case url of
-      Nothing  -> reply status400 "400: bad request"
-      Just url -> do
-        name <- liftIO (insert table url)
-        logStr ("Registered " <> url <> " -> " <> name)
-        render (done $ url' <> name)
-
-  post "api" $ do
-    url <- param "url"
-    case url of
-      Nothing  -> do
-        setStatus status400
-        json $ object [ "error" .= ("bad request"       :: Text )
-                      , "msg"   .= ("missing url field" :: Text ) ]
-      Just url -> do
-        name <- liftIO (insert table url)
-        logStr ("Registered " <> url <> " -> " <> name)
-        json $ object [ "link"     .= (url' <> name)
-                      , "name"     .= name
-                      , "original" .= url ]
-
-
-toTLS :: Text -> SpockT IO ()
-toTLS host = do
-  get var (redirect . new)
-  get "/" (redirect $ new "")
-  where new url = "https://" <> host <> "/" <> url
+-- | 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,25 +17,32 @@ 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
 
--- Choose a random element of a list
+-- | Takes a random element of a list
 choice :: [a] -> State StdGen a
 choice xs = (xs !!) <$> randomSt (0, length xs - 1)
   where randomSt = state . randomR
 
--- Generate a random phonetic string
+-- | Generates a random phonetic string
 word :: State StdGen Name
 word = pack <$> replicateM 10 letter where
   vowels     = "aeiou"
   consonants = "bcdfghjklmnpqrstvwxyz"
   letter     = choice [vowels, consonants] >>= choice
 
--- SHA256 hash to seed a generator
+-- | SHA256 hash to seed a generator
 intHash :: Url -> Int
 intHash = decode . fromStrict . hash . encodeUtf8
 
--- Assign 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,41 +1,50 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-|
+This module defines the Breve configuration
+parser and application settings.
+-}
+module Breve.Settings
+( AppSettings(..)
+, createEmptyIfMissing
+, settings
+) where
 
-module Breve.Settings where
+import Paths_breve (getDataFileName)
 
-import Control.Monad                   (when)
-import System.Environment              (lookupEnv)
-import System.Environment.XDG.BaseDir
-import System.Directory                (doesFileExist)
-import Data.Text                       (Text, pack)
+import Control.Monad                  (when)
+import System.Environment             (lookupEnv)
+import System.Directory               (doesFileExist, getXdgDirectory, XdgDirectory(..))
+import Data.Text                      (Text, pack)
 import Data.Configurator
 import Data.Monoid
 
-import Network.Wai.Handler.WarpTLS     (TLSSettings (..), tlsSettingsChain)
-import Network.TLS                     (Version (..))
-import Network.TLS.Extra               (ciphersuite_strong)
+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
+  , staticDir   :: FilePath     -- ^ path of the static assets
+  , 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"
@@ -50,14 +59,16 @@ settings path = do
     url  = "https://" <> host <> port <> "/"
 
   baseURL <- lookupDefault url config "baseurl"
+  static <- getDataFileName "static/"
 
   createEmptyIfMissing urls
 
   return AppSettings
-    { bindHost = host
-    , bindPort = portnum
-    , bindUrl  = baseURL
-    , urlTable = urls
+    { bindHost  = host
+    , bindPort  = portnum
+    , bindUrl   = baseURL
+    , urlTable  = urls
+    , staticDir = static
     , tlsSettings = (tlsSettingsChain cert chain key)
       { tlsAllowedVersions = [TLS12, TLS11]
       , tlsCiphers = ciphersuite_strong

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,40 +1,75 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
 
-import Application
-import Breve.Settings
+{-|
+This is the main module, which actually
+run the Breve webserver.
+-}
+module Main where
+
+-- Breve modules
+import Application     (AppEnv(..), breve, emptyApp)
+import Breve.Settings  (AppSettings(..), settings)
 import Breve.UrlTable
 
-import Data.Text          (Text, unpack)
-import Data.Maybe         (listToMaybe)
-import Control.Concurrent (forkIO)
-import Control.Monad
-import System.Environment (getArgs)
+-- Data conversions
+import Data.String     (IsString(..))
+import Data.Maybe      (listToMaybe)
+import Data.Text       (unpack)
 
-import Web.Spock.Core
-import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings)
-import Network.Wai.Handler.Warp    (run, defaultSettings, setPort)
+-- IO
+import Data.Text.IO        as T
+import Control.Exception   as E
+import Control.Monad       (when, void)
+import Control.Concurrent  (forkIO)
+import System.Environment  (getArgs)
 
-runBreve :: TLSSettings -> Int -> SpockT IO () -> IO ()
-runBreve tlsSettings port spock =
-  spockAsApp (spockT id spock) >>= runTLS tlsSettings settings
-  where settings = setPort port defaultSettings
+-- Web server
+import Servant                      (Application)
+import Network.Wai.Handler.Warp     (run, defaultSettings, setPort, setHost)
+import Network.Wai.Handler.WarpTLS  (runTLS)
+
+-- Middlewares
+import Network.Wai.Middleware.RequestLogger (logStdout)
+import Network.Wai.Middleware.ForceSSL      (forceSSL)
 
 
-runTLSRedirect :: Text -> IO ()
-runTLSRedirect = spockAsApp . spockT id . toTLS >=> run 80
-
-
-forkIO' :: IO () -> IO ()
-forkIO' = fmap (const ()) . forkIO
+-- * Helpers
 
+-- | Runs Breve on the Warp webserver
+runApp :: AppSettings -> Application -> IO ()
+runApp (AppSettings{..}) =
+  runTLS tlsSettings warpSettings
+  where
+    host = unpack bindHost
+    warpSettings = setPort bindPort $
+                   setHost (fromString host) defaultSettings
 
+-- | Main
+--
+-- Reads the configuration (given as the unique cli argument),
+-- sets things accordingly and runs the webserver.
 main :: IO ()
 main = do
-  configPath       <- fmap listToMaybe getArgs
-  AppSettings {..} <- settings configPath
-  table            <- load urlTable
+  configPath               <- fmap listToMaybe getArgs
+  config@(AppSettings{..}) <- settings configPath
+  table                    <- load urlTable
 
-  when (bindPort == 443) (forkIO' $ runTLSRedirect bindHost)
+  -- Redirect from HTTP to HTTPS when listening
+  -- on the standard port
+  when (bindPort == 443) $ void $
+    forkIO (run 80 $ forceSSL emptyApp)
 
-  putStrLn ("Serving on " ++ unpack bindUrl)
-  runBreve tlsSettings bindPort (app bindUrl table)
+  -- 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
+
+  -- The environment needed while running
+  let env = AppEnv bindUrl table staticDir
+
+  handle exit $ do
+    T.putStrLn ("Serving on " <> bindUrl)
+    runApp config (middlewares $ breve env)

src/Views.hs

@@ -1,22 +1,15 @@
-{-# 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 Data.Text.Lazy                (toStrict)
-import Text.Blaze.Html.Renderer.Text (renderHtml)
-import Text.Blaze.Html5              as H
-import Text.Blaze.Html5.Attributes   as A
-import qualified Web.Spock.Core      as S
-
-render :: Html -> S.ActionT IO ()
-render = S.html . toStrict . renderHtml
-
-done :: Text -> Html
-done url = template $ do
-  "here's your new link: "
-  a ! href (toValue url) $ (toHtml url)
+import Data.Text                   (Text)
+import Text.Blaze.Html5            as H
+import Text.Blaze.Html5.Attributes as A
 
+-- | The homepage
 index :: Html
 index = template $ do
   H.form ! method "POST" $ do
@@ -24,9 +17,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
@@ -36,10 +42,10 @@ template fill =
       meta ! name "keywords" ! content "url, shortener"
       meta ! name "author" ! content "Michele Guerini Rocco"
       meta ! charset "utf-8"
-      link ! rel "stylesheet" ! href "main.css" ! type_ "text/css"
-      link ! rel "apple-touch-icon" ! href "icon-big.png"
-      link ! rel "icon" ! type_ "image/png" ! href "/icon-medium.png" ! sizes "96x96"
-      link ! rel "icon" ! type_ "image/png" ! href "/icon-small.png" ! sizes "16x16"
+      link ! rel "stylesheet" ! href "/static/main.css" ! type_ "text/css"
+      link ! rel "apple-touch-icon" ! href "static/icon-big.png"
+      link ! rel "icon" ! type_ "image/png" ! href "/static/icon-medium.png" ! sizes "96x96"
+      link ! rel "icon" ! type_ "image/png" ! href "/static/icon-small.png" ! sizes "16x16"
     body $ do
       header $ do
           h1 $ a ! href "/" $ "BREVE"