improve documentation

master
Michele Guerini Rocco 2019-11-06 15:09:02 +01:00
parent fc3b5ba642
commit 5108b035a4
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450
6 changed files with 122 additions and 46 deletions

View File

@ -5,6 +5,10 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-|
This module contains the web application
and API implementation of Breve.
-}
module Application where module Application where
-- Breve modules -- Breve modules
@ -36,7 +40,7 @@ import GHC.TypeNats (Nat)
-- * Types -- * Types
-- | API successful reply -- | 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 -- handler when the url has been shortned
-- successfully. -- successfully.
data ApiReply = ApiReply data ApiReply = ApiReply
@ -55,13 +59,25 @@ instance FromForm Url where
-- | API spec -- | API spec
-- --
-- Breve has three main components: -- Breve has two main components:
--
-- 1. the web app -- 1. the web app
-- 2. the JSON API -- 2. the JSON API itself
-- 3. the static files server
type Breve = API :<|> App type Breve = API :<|> App
-- | Web app spec -- | 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 = type App =
Get '[HTML] Html Get '[HTML] Html
:<|> "static" :> Raw :<|> "static" :> Raw
@ -69,18 +85,15 @@ type App =
:<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html :<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html
-- | JSON API spec -- | JSON API spec
--
-- +----------+------+----------------------+
-- | path | type | description |
-- +==========+======+======================+
-- | / | POST | upload a new url |
-- +----------+------+----------------------+
type API = type API =
"api" :> ReqBody '[FormUrlEncoded] Url :> Post '[JSON] ApiReply "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 application
-- --
-- Breve takes as parameters the bind url and the urls table -- Breve takes as parameters the bind url and the urls table
@ -126,7 +139,7 @@ uploader bindUrl table url = do
logStr ("Registered " <> url <> " -> " <> name) logStr ("Registered " <> url <> " -> " <> name)
pure (done $ bindUrl <> 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. -- the shortned one in an 'ApiReply' as JSON.
api :: Url -> UrlTable -> Url -> Handler ApiReply api :: Url -> UrlTable -> Url -> Handler ApiReply
api bindUrl table url = do api bindUrl table url = do
@ -141,4 +154,12 @@ api bindUrl table url = do
-- | Handy function to log to stdout -- | Handy function to log to stdout
logStr :: Text -> Handler () 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

View File

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

View File

@ -1,32 +1,42 @@
module Breve.Settings where {-# LANGUAGE OverloadedStrings #-}
import Control.Monad (when) {-|
import System.Environment (lookupEnv) This module defines the Breve configuration
import System.Environment.XDG.BaseDir parser and application settings.
import System.Directory (doesFileExist) -}
import Data.Text (Text, pack) 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.Configurator
import Data.Monoid import Data.Monoid
import Network.Wai.Handler.WarpTLS (TLSSettings (..), tlsSettingsChain) import Network.Wai.Handler.WarpTLS (TLSSettings (..), tlsSettingsChain)
import Network.TLS (Version (..)) import Network.TLS (Version (..))
import Network.TLS.Extra (ciphersuite_strong) import Network.TLS.Extra (ciphersuite_strong)
-- | Breve settings
data AppSettings = AppSettings data AppSettings = AppSettings
{ bindHost :: Text { bindHost :: Text -- ^ the host to bind to
, bindPort :: Int , bindPort :: Int -- ^ the port to bind to
, bindUrl :: Text , bindUrl :: Text -- ^ the url used to reach breve
, urlTable :: FilePath , urlTable :: FilePath -- ^ path where to save the url table
, tlsSettings :: TLSSettings , tlsSettings :: TLSSettings -- ^ warp TLS settings
} }
-- | Initialises a file if it doesn't exist
createEmptyIfMissing :: FilePath -> IO () createEmptyIfMissing :: FilePath -> IO ()
createEmptyIfMissing file = do createEmptyIfMissing file = do
exists <- doesFileExist file exists <- doesFileExist file
when (not exists) (writeFile file "") when (not exists) (writeFile file "")
-- | Configuration file parser
settings :: Maybe FilePath -> IO AppSettings settings :: Maybe FilePath -> IO AppSettings
settings path = do settings path = do
configPath <- case path of configPath <- case path of

View File

@ -1,3 +1,7 @@
{-|
This modules defines the data structure used
to store the URLs in memory and on disk.
-}
module Breve.UrlTable module Breve.UrlTable
( UrlTable ( UrlTable
, load , load
@ -12,16 +16,23 @@ import Control.Concurrent (forkIO, threadDelay)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import qualified Data.HashTable.IO as H import qualified Data.HashTable.IO as H
-- | The hash table that stores URLs
type UrlTable = H.CuckooHashTable Name Url 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 :: UrlTable -> FilePath -> IO ()
sync table file = forever $ do sync table file = forever $ do
threadDelay (round 3.0e8) threadDelay (round 3.0e8)
content <- show <$> H.toList table content <- show <$> H.toList table
writeFile file content 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 :: FilePath -> IO UrlTable
load file = do load file = do
content <- readFile file content <- readFile file
@ -31,11 +42,11 @@ load file = do
forkIO (sync table file) forkIO (sync table file)
return table 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 :: UrlTable -> Url -> IO Name
insert table url = H.insert table new url >> return new insert table url = H.insert table new url >> return new
where new = nameHash url 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 :: UrlTable -> Name -> IO (Maybe Url)
extract = H.lookup extract = H.lookup

View File

@ -1,6 +1,12 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-|
This is the main module, which actually
run the Breve webserver.
-}
module Main where
-- Breve modules -- Breve modules
import Application import Application
import Breve.Settings import Breve.Settings
@ -39,8 +45,8 @@ run (AppSettings{..}) =
-- | Main -- | Main
-- --
-- Reads the config (given as the unique argument) -- Reads the configuration (given as the unique cli argument),
-- and runs the breve web app -- sets things accordingly and runs the webserver.
main :: IO () main :: IO ()
main = do main = do
configPath <- fmap listToMaybe getArgs configPath <- fmap listToMaybe getArgs
@ -48,6 +54,9 @@ main = do
table <- load urlTable table <- load urlTable
static <- getDataFileName "static/" static <- getDataFileName "static/"
-- Middlewares are just functions of type
-- (Application -> Application). We use a couple here
-- to add requests logging and HTTPS redirection.
let let
middlewares = middlewares =
logStdout . logStdout .

View File

@ -1,16 +1,17 @@
{-# LANGUAGE OverloadedStrings #-} {-# 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 module Views where
import Data.Text (Text) import Data.Text (Text)
import Text.Blaze.Html5 as H import Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes as A import Text.Blaze.Html5.Attributes as A
done :: Text -> Html -- | The homepage
done url = template $ do
"here's your new link: "
a ! href (toValue url) $ (toHtml url)
index :: Html index :: Html
index = template $ do index = template $ do
H.form ! method "POST" $ do H.form ! method "POST" $ do
@ -18,9 +19,22 @@ index = template $ do
input ! type_ "text" ! name "url" input ! type_ "text" ! name "url"
input ! type_ "submit" ! value "go" 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 :: Text -> Html
message = template . toHtml message = template . toHtml
-- | The main Breve template
--
-- Takes HTML code and embeds it in the
-- inner page container.
template :: Html -> Html template :: Html -> Html
template fill = template fill =
docTypeHtml $ do docTypeHtml $ do