diff --git a/src/Application.hs b/src/Application.hs index f98c5d8..333d0e7 100644 --- a/src/Application.hs +++ b/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,18 +85,15 @@ 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 @@ -126,7 +139,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 +154,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 diff --git a/src/Breve/Generator.hs b/src/Breve/Generator.hs index 122d8a3..b375d23 100644 --- a/src/Breve/Generator.hs +++ b/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 diff --git a/src/Breve/Settings.hs b/src/Breve/Settings.hs index db9dea3..7d4f0b8 100644 --- a/src/Breve/Settings.hs +++ b/src/Breve/Settings.hs @@ -1,32 +1,42 @@ -module Breve.Settings where +{-# LANGUAGE OverloadedStrings #-} -import Control.Monad (when) -import System.Environment (lookupEnv) -import System.Environment.XDG.BaseDir -import System.Directory (doesFileExist) -import Data.Text (Text, pack) +{-| +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.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 + , 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 diff --git a/src/Breve/UrlTable.hs b/src/Breve/UrlTable.hs index 7ffb552..d97fbe0 100644 --- a/src/Breve/UrlTable.hs +++ b/src/Breve/UrlTable.hs @@ -1,3 +1,7 @@ +{-| +This modules defines the data structure used +to store the URLs in memory and on disk. +-} module Breve.UrlTable ( UrlTable , load @@ -12,16 +16,23 @@ 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 writes a 'UrlTable' to a file +-- +-- The table is stored in a text file +-- as Haskell code for semplicity. sync :: UrlTable -> FilePath -> IO () sync table file = forever $ do threadDelay (round 3.0e8) content <- show <$> H.toList table writeFile file content --- | Load a url table from a file +-- | Loads a URL table from a file +-- +-- The format should be the same one used +-- by the 'sync' function. load :: FilePath -> IO UrlTable load file = do content <- readFile file @@ -31,11 +42,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 diff --git a/src/Main.hs b/src/Main.hs index bf1b07e..58d5c9d 100644 --- a/src/Main.hs +++ b/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 @@ -39,8 +45,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,6 +54,9 @@ main = do table <- load urlTable static <- getDataFileName "static/" + -- Middlewares are just functions of type + -- (Application -> Application). We use a couple here + -- to add requests logging and HTTPS redirection. let middlewares = logStdout . diff --git a/src/Views.hs b/src/Views.hs index 6e42602..909312e 100644 --- a/src/Views.hs +++ b/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