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