breve-0.5.1.0: src/Application.hs

{-# 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 Views

-- Misc
import Control.Monad.IO.Class   (liftIO)
import Control.Monad.Reader     (ReaderT, runReaderT, asks)
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.Html.Renderer.Utf8 (renderHtml)

-- API definition
import Servant
import Servant.HTML.Blaze            (HTML)
import Web.FormUrlEncoded            (FromForm(..), parseUnique)
import qualified Servant.RawM.Server as R


-- * Types

-- | Custom handler type with a
-- reader environment
type AppM = ReaderT AppEnv Handler

-- | The environment associated
-- to 'AppM'
data AppEnv = AppEnv
  { bindUrl   :: Text
  , urlTable  :: UrlTable
  , staticDir :: FilePath
  }

-- | 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

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

instance FromForm UrlForm where
  fromForm f = UrlForm <$> parseUnique "url" f


-- * Breve API

-- | API spec
--
-- Breve has two main components:
--
-- 1. the web app
-- 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" :> R.RawM
  :<|> Capture "name" Name :> Redirect
  :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html

-- | JSON API spec
--
-- +----------+------+----------------------+
-- | path     | type | description          |
-- +==========+======+======================+
-- | /api     | POST | upload a new url     |
-- +----------+------+----------------------+
type API =
  "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply

-- | Breve application
--
-- Notes:
--
-- * @api@ is an empty value that brings the type
-- 'Breve' to the 'serve' function. If Haskell were
-- depedently typed it would just be @serve Breve@
--
-- * hoistServer flattens the AppM monad stack
-- in the breveServer definition
breve :: AppEnv -> Application
breve env = serve api (hoistServer api nt breveServer)
  where api = Proxy :: Proxy Breve
        nt x = runReaderT x env

-- | 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.
--
-- Note: 'RawM' is  required because Servant doesn't
-- allow the creation of a raw 'Application' from a
-- monadic value.
breveServer :: ServerT Breve AppM
breveServer = api :<|> app
  where app =  homepage
          :<|> (R.serveDirectoryWebApp =<< asks staticDir)
          :<|> resolver
          :<|> uploader

-- | Serves the homepage
homepage :: AppM Html
homepage = pure index

-- | Resolves a 'Name' to the full 'Url'
resolver :: Name -> AppM Redirection
resolver name = do
  table <- asks urlTable
  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 :: UrlForm -> AppM Html
uploader (UrlForm url) = do
  table <- asks urlTable
  bind  <- asks bindUrl
  name  <- liftIO (insert table url)
  logStr ("Registered " <> url <> " -> " <> name)
  pure (done $ bind <> name)

-- | Takes a 'Url' via POST and returns
-- the shortned one in an 'ApiReply' as JSON.
api :: UrlForm -> AppM ApiReply
api (UrlForm url) = do
  table <- asks urlTable
  bind  <- asks bindUrl
  name  <- liftIO (insert table url)
  logStr ("Registered " <> url <> " -> " <> name)
  pure $ ApiReply { link     = (bind <> name)
                  , name     = name
                  , original = url
                  }

-- * Misc

-- | Handy function to log to stdout
logStr :: Text -> AppM ()
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