Compare commits
4 Commits
fc3b5ba642
...
7e1e95fa2a
Author | SHA1 | Date |
---|---|---|
Michele Guerini Rocco | 7e1e95fa2a | |
Michele Guerini Rocco | 7fdfb25ce0 | |
Michele Guerini Rocco | 101f5c06af | |
Michele Guerini Rocco | 5108b035a4 |
|
@ -32,10 +32,10 @@ executable breve
|
|||
other-extensions: OverloadedStrings
|
||||
build-depends: base >=4.8 && <5.0,
|
||||
warp, warp-tls, tls, blaze-html, blaze-markup,
|
||||
servant-server, servant, servant-blaze, http-api-data,
|
||||
wai, wai-extra, streaming-commons,
|
||||
servant-server, servant, servant-blaze,
|
||||
wai, wai-extra, streaming-commons, http-api-data,
|
||||
transformers, mtl,
|
||||
text, aeson, bytestring, binary,
|
||||
hashtables, cryptohash, random,
|
||||
xdg-basedir, configurator, directory
|
||||
configurator, directory
|
||||
ghc-options: -threaded -O2
|
||||
|
|
|
@ -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,24 +85,28 @@ 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
|
||||
breve :: FilePath -> Url -> UrlTable -> Application
|
||||
breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table)
|
||||
|
||||
-- | 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
|
||||
|
||||
|
@ -126,7 +146,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 +161,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,39 +1,49 @@
|
|||
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
|
||||
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"
|
||||
|
|
|
@ -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 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 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 @@ 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
|
||||
|
|
44
src/Main.hs
44
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
|
||||
|
@ -13,24 +19,27 @@ import Data.String (IsString(..))
|
|||
import Data.Maybe (listToMaybe)
|
||||
|
||||
-- IO
|
||||
import Control.Monad (when, void)
|
||||
import Control.Exception as E
|
||||
import Control.Concurrent (forkIO)
|
||||
import System.Environment (getArgs)
|
||||
import Data.Text.IO as T
|
||||
import Data.Text.IO as T
|
||||
|
||||
-- Web server
|
||||
import Servant (Application)
|
||||
import Network.Wai.Handler.Warp (defaultSettings, setPort, setHost)
|
||||
import Network.Wai.Handler.Warp (run, defaultSettings, setPort, setHost)
|
||||
import Network.Wai.Handler.WarpTLS (runTLS, TLSSettings)
|
||||
|
||||
-- Middlewares
|
||||
import Network.Wai.Middleware.ForceSSL (forceSSL)
|
||||
import Network.Wai.Middleware.RequestLogger (logStdout)
|
||||
import Network.Wai.Middleware.ForceSSL (forceSSL)
|
||||
|
||||
|
||||
-- * Helpers
|
||||
|
||||
-- | Runs Breve on the Warp webserver
|
||||
run :: AppSettings -> Application -> IO ()
|
||||
run (AppSettings{..}) =
|
||||
runApp :: AppSettings -> Application -> IO ()
|
||||
runApp (AppSettings{..}) =
|
||||
runTLS tlsSettings warpSettings
|
||||
where
|
||||
host = unpack bindHost
|
||||
|
@ -39,8 +48,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,10 +57,19 @@ main = do
|
|||
table <- load urlTable
|
||||
static <- getDataFileName "static/"
|
||||
|
||||
let
|
||||
middlewares =
|
||||
logStdout .
|
||||
(if bindPort == 433 then forceSSL else id)
|
||||
-- Redirect from HTTP to HTTPS when listening
|
||||
-- on the standard port
|
||||
when (bindPort == 443) $ void $
|
||||
forkIO (run 80 $ forceSSL emptyApp)
|
||||
|
||||
T.putStrLn ("Serving on " <> bindUrl)
|
||||
run config (middlewares $ breve static 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)
|
||||
|
|
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