80 lines
2.0 KiB
Haskell
80 lines
2.0 KiB
Haskell
{-# 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
|