breve/src/Application.hs

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