rnhmjoj/breve
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

use a newtype instance a type synonym instance

Browse Source
This commit is contained in:
Michele Guerini Rocco 2019-11-07 10:11:18 +01:00
parent 7e1e95fa2a
commit da107970fb
Signed by: rnhmjoj
GPG Key ID: BFBAF4C975F76450
1 changed files with 14 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Application.hs
View File

@ -1,9 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-| {-|
This module contains the web application This module contains the web application
@ -51,8 +49,13 @@ data ApiReply = ApiReply
instance ToJSON ApiReply instance ToJSON ApiReply
instance FromForm Url where -- | This type is just a wrapped around a 'Text'
fromForm f = parseUnique "url" f -- 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 -- * Breve API
@ -82,7 +85,7 @@ type App =
Get '[HTML] Html Get '[HTML] Html
:<|> "static" :> Raw :<|> "static" :> Raw
:<|> Capture "name" Name :> Redirect :<|> Capture "name" Name :> Redirect
:<|> ReqBody '[FormUrlEncoded] Url :> Post '[HTML] Html :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html
-- | JSON API spec -- | JSON API spec
-- --
@ -92,7 +95,7 @@ type App =
-- | / | POST | upload a new url | -- | / | POST | upload a new url |
-- +----------+------+----------------------+ -- +----------+------+----------------------+
type API = type API =
"api" :> ReqBody '[FormUrlEncoded] Url :> Post '[JSON] ApiReply "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply
-- | Breve application -- | Breve application
-- --
@ -138,18 +141,18 @@ resolver table name = do
pure (addHeader url NoContent) pure (addHeader url NoContent)
-- | Takes a 'Url' via POST -- | Takes a 'UrlForm' via POST
-- and prints the shortned one -- and prints the shortned one
uploader :: Url -> UrlTable -> Url -> Handler Html uploader :: Url -> UrlTable -> UrlForm -> Handler Html
uploader bindUrl table url = do uploader bindUrl table (UrlForm url) = do
name <- liftIO (insert table url) name <- liftIO (insert table url)
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 -> UrlForm -> Handler ApiReply
api bindUrl table url = do api bindUrl table (UrlForm url) = do
name <- liftIO (insert table url) name <- liftIO (insert table url)
logStr ("Registered " <> url <> " -> " <> name) logStr ("Registered " <> url <> " -> " <> name)
pure $ ApiReply { link = (bindUrl <> name) pure $ ApiReply { link = (bindUrl <> name)