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