{-# LANGUAGE OverloadedStrings #-} module Application where import Breve.Generator import Breve.UrlTable import Paths_breve (getDataFileName) import Views import Data.Monoid import Control.Monad.IO.Class (liftIO) import Data.Aeson hiding (json) import Data.Text (Text) import qualified Data.Text.IO as T import Web.Spock.Core import Network.HTTP.Types.Status import Network.Wai (Middleware) import Network.Wai.Middleware.Static import Network.Wai.Middleware.RequestLogger serveStatic :: FilePath -> Middleware serveStatic = staticPolicy . addBase reply :: Status -> Text -> ActionT IO () reply code text = setStatus code >> render (message text) logStr :: Text -> ActionT IO () logStr = liftIO . T.putStrLn app :: Url -> UrlTable -> SpockT IO () app url' table = do static <- liftIO (getDataFileName "static/") middleware (serveStatic static) middleware logStdout get "/" $ render index get var $ \name -> do url <- liftIO (extract table name) case url of Nothing -> reply status404 "404: does not exist" Just url -> do logStr ("Resolved " <> name <> " -> " <> url) redirect url post "/" $ do url <- param "url" case url of Nothing -> reply status400 "400: bad request" Just url -> do name <- liftIO (insert table url) logStr ("Registered " <> url <> " -> " <> name) render (done $ url' <> name) post "api" $ do url <- param "url" case url of Nothing -> do setStatus status400 json $ object [ "error" .= ("bad request" :: Text ) , "msg" .= ("missing url field" :: Text ) ] Just url -> do name <- liftIO (insert table url) logStr ("Registered " <> url <> " -> " <> name) json $ object [ "link" .= (url' <> name) , "name" .= name , "original" .= url ] toTLS :: Text -> SpockT IO () toTLS host = do get var (redirect . new) get "/" (redirect $ new "") where new url = "https://" <> host <> "/" <> url