breve 0.4.5.1 → 0.5.0.0
raw patch · 8 files changed
+320/−146 lines, 8 filesdep +http-api-datadep +servantdep +servant-blazedep −Spockdep −Spock-coredep −http-typessetup-changed
Dependencies added: http-api-data, servant, servant-blaze, servant-server, streaming-commons
Dependencies removed: Spock, Spock-core, http-types, transformers, wai-middleware-static, xdg-basedir
Files
- Setup.hs +0/−0
- breve.cabal +19/−16
- src/Application.hs +151/−55
- src/Breve/Generator.hs +18/−7
- src/Breve/Settings.hs +26/−20
- src/Breve/UrlTable.hs +22/−4
- src/Main.hs +58/−24
- src/Views.hs +26/−20
Setup.hs view
breve.cabal view
@@ -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 @@ 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, servant-server, 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 view
@@ -1,79 +1,175 @@-{-# 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+-- Misc import Control.Monad.IO.Class (liftIO)-import Data.Aeson hiding (json)-import Data.Text (Text) 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) -serveStatic :: FilePath -> Middleware-serveStatic = staticPolicy . addBase+-- API definition+import Servant+import Servant.HTML.Blaze (HTML)+import Web.FormUrlEncoded (FromForm(..), parseUnique) -reply :: Status -> Text -> ActionT IO ()-reply code text = setStatus code >> render (message text)+-- * Types +-- | 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 -logStr :: Text -> ActionT IO ()-logStr = liftIO . T.putStrLn+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 -app :: Url -> UrlTable -> SpockT IO ()-app url' table = do- static <- liftIO (getDataFileName "static/")+instance FromForm UrlForm where+ fromForm f = UrlForm <$> parseUnique "url" f - middleware (serveStatic static)- middleware logStdout - get "/" $ render index+-- * Breve API - 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+-- | API spec+--+-- Breve has two main components:+--+-- 1. the web app+-- 2. the JSON API itself+type Breve = API :<|> App - 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)+-- | 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+ :<|> Capture "name" Name :> Redirect+ :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html - 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 ]+-- | JSON API spec+--+-- +----------+------+----------------------++-- | path | type | description |+-- +==========+======+======================++-- | /api | POST | upload a new url |+-- +----------+------+----------------------++type API =+ "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply +-- | Breve application+breve :: FilePath -- ^ static assets path+ -> Url -- ^ bind url+ -> UrlTable -- ^ url hashtable+ -> Application+breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table) -toTLS :: Text -> SpockT IO ()-toTLS host = do- get var (redirect . new)- get "/" (redirect $ new "")- where new url = "https://" <> host <> "/" <> url+-- | 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.+breveServer :: FilePath -> Url -> UrlTable -> Server Breve+breveServer static url table =+ api url table :<|> app+ where app = homepage :<|>+ serveDirectoryWebApp static :<|>+ resolver table :<|>+ uploader url table++-- | Serves the homepage+homepage :: Handler Html+homepage = pure index++-- | Resolves a 'Name' to the full 'Url'+resolver :: UrlTable -> Name -> Handler Redirection+resolver table name = do+ 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)+++-- | Takes a 'UrlForm' via POST+-- and prints the shortned one+uploader :: Url -> UrlTable -> UrlForm -> Handler Html+uploader bindUrl table (UrlForm url) = do+ name <- liftIO (insert table url)+ logStr ("Registered " <> url <> " -> " <> name)+ pure (done $ bindUrl <> name)++-- | Takes a 'Url' via POST and returns+-- the shortned one in an 'ApiReply' as JSON.+api :: Url -> UrlTable -> UrlForm -> Handler ApiReply+api bindUrl table (UrlForm url) = do+ name <- liftIO (insert table url)+ logStr ("Registered " <> url <> " -> " <> name)+ pure $ ApiReply { link = (bindUrl <> name)+ , name = name+ , original = url+ }++-- * Misc++-- | Handy function to log to stdout+logStr :: Text -> Handler ()+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
src/Breve/Generator.hs view
@@ -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.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 view
@@ -1,41 +1,47 @@-{-# LANGUAGE OverloadedStrings #-}--module Breve.Settings where+{-|+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.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+ , 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"
src/Breve/UrlTable.hs view
@@ -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 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 @@ 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 view
@@ -1,40 +1,74 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} -import Application+{-|+This is the main module, which actually+run the Breve webserver.+-}+module Main where++-- Breve modules+import Application (breve, emptyApp) import Breve.Settings import Breve.UrlTable+import Paths_breve (getDataFileName) -import Data.Text (Text, unpack)-import Data.Maybe (listToMaybe)+-- Data conversions+import Data.Text (Text, unpack)+import Data.String (IsString(..))+import Data.Maybe (listToMaybe)++-- IO+import Control.Monad (when, void)+import Control.Exception as E import Control.Concurrent (forkIO)-import Control.Monad import System.Environment (getArgs)--import Web.Spock.Core-import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings)-import Network.Wai.Handler.Warp (run, defaultSettings, setPort)--runBreve :: TLSSettings -> Int -> SpockT IO () -> IO ()-runBreve tlsSettings port spock =- spockAsApp (spockT id spock) >>= runTLS tlsSettings settings- where settings = setPort port defaultSettings+import Data.Text.IO as T +-- Web server+import Servant (Application)+import Network.Wai.Handler.Warp (run, defaultSettings, setPort, setHost)+import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings) -runTLSRedirect :: Text -> IO ()-runTLSRedirect = spockAsApp . spockT id . toTLS >=> run 80+-- Middlewares+import Network.Wai.Middleware.RequestLogger (logStdout)+import Network.Wai.Middleware.ForceSSL (forceSSL) -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+ static <- getDataFileName "static/" - 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++ handle exit $ do+ T.putStrLn ("Serving on " <> bindUrl)+ runApp config (middlewares $ breve static bindUrl table)
src/Views.hs view
@@ -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 @@ 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 @@ 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"