improve documentation
This commit is contained in:
parent
fc3b5ba642
commit
5108b035a4
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
13
src/Main.hs
13
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 .
|
||||
|
24
src/Views.hs
24
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
|
||||
|
Loading…
Reference in New Issue
Block a user