145 lines
3.7 KiB
Haskell
145 lines
3.7 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
|
|
module Application where
|
|
|
|
-- Breve modules
|
|
import Breve.Generator
|
|
import Breve.UrlTable
|
|
import Views
|
|
|
|
-- Misc
|
|
import Data.Monoid
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import qualified Data.Text.IO as T
|
|
|
|
-- JSON conversion
|
|
import Data.Text (Text)
|
|
import Data.Aeson (ToJSON)
|
|
import GHC.Generics (Generic)
|
|
|
|
-- HTML replies
|
|
import Text.Blaze.Html5 (Html)
|
|
import Text.Blaze.Renderer.Utf8 (renderMarkup)
|
|
|
|
-- API definition
|
|
import Servant
|
|
import Servant.HTML.Blaze (HTML)
|
|
import Web.FormUrlEncoded (FromForm(..), parseUnique)
|
|
import GHC.TypeNats (Nat)
|
|
|
|
|
|
-- * Types
|
|
|
|
-- | API successful reply
|
|
-- This is the reply returned by the 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
|
|
|
|
instance ToJSON ApiReply
|
|
|
|
instance FromForm Url where
|
|
fromForm f = parseUnique "url" f
|
|
|
|
|
|
-- * Breve API
|
|
|
|
-- | API spec
|
|
--
|
|
-- Breve has three main components:
|
|
-- 1. the web app
|
|
-- 2. the JSON API
|
|
-- 3. the static files server
|
|
type Breve = API :<|> App
|
|
|
|
-- | Web app spec
|
|
type App =
|
|
Get '[HTML] Html
|
|
:<|> "static" :> Raw
|
|
:<|> Capture "name" Name :> Redirect
|
|
:<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html
|
|
|
|
-- | JSON API spec
|
|
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)
|
|
|
|
|
|
-- * 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 = renderMarkup (message "404: not found") }
|
|
Just url -> do
|
|
logStr ("Resolved " <> name <> " -> " <> url)
|
|
pure (addHeader url NoContent)
|
|
|
|
|
|
-- | Takes a 'Url' via POST
|
|
-- and prints the shortned one
|
|
uploader :: Url -> UrlTable -> Url -> Handler Html
|
|
uploader bindUrl table 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 -> Url -> Handler ApiReply
|
|
api bindUrl table 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
|