67 lines
1.8 KiB
Haskell
67 lines
1.8 KiB
Haskell
{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}
|
|
module Application where
|
|
|
|
import Breve.Generator
|
|
import Breve.UrlTable
|
|
import Paths_breve (getDataFileName)
|
|
import Views
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Text.Printf (printf)
|
|
import Data.Aeson hiding (json)
|
|
import Data.Monoid
|
|
import Data.Text (pack, unpack)
|
|
import Data.Text.Lazy.Encoding (decodeUtf8)
|
|
import Data.Text.Lazy (toStrict)
|
|
|
|
import Web.Spock.Safe
|
|
import Network.Wai (Middleware)
|
|
import Network.Wai.Middleware.Static
|
|
import Network.Wai.Middleware.RequestLogger
|
|
|
|
logStr :: String -> ActionT IO ()
|
|
logStr = liftIO . putStrLn
|
|
|
|
|
|
serveStatic :: FilePath -> Middleware
|
|
serveStatic = staticPolicy . addBase
|
|
|
|
|
|
app :: Url -> UrlTable -> SpockT IO ()
|
|
app url' table = do
|
|
static <- liftIO (getDataFileName "static/")
|
|
|
|
middleware (serveStatic static)
|
|
middleware logStdout
|
|
|
|
get "/" $ html (render index)
|
|
|
|
get var $ \name -> do
|
|
url <- liftIO (extract table name)
|
|
case url of
|
|
Nothing -> html (render $ message "404: this one does not exist")
|
|
Just url -> do
|
|
logStr (printf "Resolved %s -> %s" name url)
|
|
redirect (pack url)
|
|
|
|
post "/" $ do
|
|
url <- fmap unpack <$> param "url"
|
|
case url of
|
|
Nothing -> html (render $ message "bad request")
|
|
Just url -> do
|
|
name <- liftIO (insert table url)
|
|
logStr (printf "Registered %s -> %s " url name)
|
|
let link = url' <> name
|
|
html (render $ done link)
|
|
|
|
post "api" $ do
|
|
url <- fmap unpack <$> param "url"
|
|
case url of
|
|
Nothing -> text "bad request"
|
|
Just url -> do
|
|
name <- liftIO (insert table url)
|
|
logStr (printf "Registered %s -> %s " url name)
|
|
json $ object [ "link" .= pack (url' <> name)
|
|
, "name" .= name
|
|
, "original" .= url ]
|