Compare commits
5 Commits
7e1e95fa2a
...
6bcaff8b3a
Author | SHA1 | Date |
---|---|---|
Michele Guerini Rocco | 6bcaff8b3a | |
Michele Guerini Rocco | 2c5ec3e9f6 | |
Michele Guerini Rocco | d460c73bd0 | |
Michele Guerini Rocco | 2f926c6a71 | |
Michele Guerini Rocco | da107970fb |
|
@ -1,16 +1,3 @@
|
|||
dist
|
||||
cabal-dev
|
||||
*.o
|
||||
*.hi
|
||||
*.chi
|
||||
*.chs.h
|
||||
*.dyn_o
|
||||
*.dyn_hi
|
||||
.virtualenv
|
||||
.hpc
|
||||
.hsenv
|
||||
.cabal-sandbox/
|
||||
cabal.sandbox.config
|
||||
*.prof
|
||||
*.aux
|
||||
*.hp
|
||||
result
|
||||
default.nix
|
||||
|
|
34
breve.cabal
34
breve.cabal
|
@ -23,19 +23,21 @@ source-repository head
|
|||
location: https://maxwell.ydns.eu/git/rnhmjoj/breve
|
||||
|
||||
executable breve
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
other-modules: Application, Views, Breve.Settings,
|
||||
Breve.Generator, Breve.UrlTable,
|
||||
Paths_breve
|
||||
other-extensions: OverloadedStrings
|
||||
build-depends: base >=4.8 && <5.0,
|
||||
warp, warp-tls, tls, blaze-html, blaze-markup,
|
||||
servant-server, servant, servant-blaze,
|
||||
wai, wai-extra, streaming-commons, http-api-data,
|
||||
transformers, mtl,
|
||||
text, aeson, bytestring, binary,
|
||||
hashtables, cryptohash, random,
|
||||
configurator, directory
|
||||
ghc-options: -threaded -O2
|
||||
main-is: Main.hs
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
other-modules: Application, Views, Breve.Settings,
|
||||
Breve.Generator, Breve.UrlTable,
|
||||
Paths_breve
|
||||
default-extensions: OverloadedStrings
|
||||
other-extensions: RecordWildCards, DeriveGeneric,
|
||||
DataKinds, KindSignatures, TypeOperators
|
||||
build-depends: base >=4.8 && <5.0,
|
||||
warp, warp-tls, tls, blaze-html,
|
||||
servant, servant-server, servant-blaze,
|
||||
wai, wai-extra, streaming-commons, http-api-data,
|
||||
|
||||
mtl, text, aeson, bytestring, binary,
|
||||
hashtables, cryptohash, random,
|
||||
configurator, directory
|
||||
ghc-options: -threaded -O2 "-with-rtsopts=-N -qg"
|
||||
|
|
|
@ -1,9 +1,7 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
|
||||
{-|
|
||||
This module contains the web application
|
||||
|
@ -17,7 +15,6 @@ import Breve.UrlTable
|
|||
import Views
|
||||
|
||||
-- Misc
|
||||
import Data.Monoid
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Text.IO as T
|
||||
|
||||
|
@ -27,19 +24,19 @@ import Data.Aeson (ToJSON)
|
|||
import GHC.Generics (Generic)
|
||||
|
||||
-- HTML replies
|
||||
import Text.Blaze.Html5 (Html)
|
||||
import Text.Blaze.Renderer.Utf8 (renderMarkup)
|
||||
import Text.Blaze.Html5 (Html)
|
||||
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
|
||||
|
||||
-- API definition
|
||||
import Servant
|
||||
import Servant.HTML.Blaze (HTML)
|
||||
import Web.FormUrlEncoded (FromForm(..), parseUnique)
|
||||
import GHC.TypeNats (Nat)
|
||||
|
||||
|
||||
-- * Types
|
||||
|
||||
-- | API successful reply
|
||||
--
|
||||
-- This is the reply returned by the JSON API
|
||||
-- handler when the url has been shortned
|
||||
-- successfully.
|
||||
|
@ -51,8 +48,13 @@ data ApiReply = ApiReply
|
|||
|
||||
instance ToJSON ApiReply
|
||||
|
||||
instance FromForm Url where
|
||||
fromForm f = parseUnique "url" f
|
||||
-- | This type is just a wrapper 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,22 +84,23 @@ 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
|
||||
--
|
||||
-- +----------+------+----------------------+
|
||||
-- | path | type | description |
|
||||
-- +==========+======+======================+
|
||||
-- | / | POST | upload a new url |
|
||||
-- | /api | POST | upload a new url |
|
||||
-- +----------+------+----------------------+
|
||||
type API =
|
||||
"api" :> ReqBody '[FormUrlEncoded] Url :> Post '[JSON] ApiReply
|
||||
"api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply
|
||||
|
||||
-- | Breve application
|
||||
--
|
||||
-- Breve takes as parameters the bind url and the urls table
|
||||
breve :: FilePath -> Url -> UrlTable -> Application
|
||||
breve :: FilePath -- ^ static assets path
|
||||
-> Url -- ^ bind url
|
||||
-> UrlTable -- ^ url hashtable
|
||||
-> Application
|
||||
breve static url table = serve (Proxy :: Proxy Breve) (breveServer static url table)
|
||||
|
||||
-- | Empty application
|
||||
|
@ -132,24 +135,24 @@ resolver table name = do
|
|||
url <- liftIO (extract table name)
|
||||
case url of
|
||||
Nothing ->
|
||||
throwError $ err404 { errBody = renderMarkup (message "404: not found") }
|
||||
throwError $ err404 { errBody = renderHtml (message "404: not found") }
|
||||
Just url -> do
|
||||
logStr ("Resolved " <> name <> " -> " <> url)
|
||||
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)
|
||||
|
|
|
@ -1,5 +1,3 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
This module defines the Breve configuration
|
||||
parser and application settings.
|
||||
|
|
|
@ -1,5 +1,4 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
{-|
|
||||
This is the main module, which actually
|
||||
|
@ -8,7 +7,7 @@ run the Breve webserver.
|
|||
module Main where
|
||||
|
||||
-- Breve modules
|
||||
import Application
|
||||
import Application (breve, emptyApp)
|
||||
import Breve.Settings
|
||||
import Breve.UrlTable
|
||||
import Paths_breve (getDataFileName)
|
||||
|
|
|
@ -1,5 +1,3 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
{-|
|
||||
This module contains the HTML pages used by the
|
||||
web application. These are all obtained by filling
|
||||
|
|
Loading…
Reference in New Issue