packages feed

breve 0.5.0.0 → 0.5.1.0

raw patch · 7 files changed

+91/−55 lines, 7 filesdep +servant-rawm-serverdep −servantsetup-changed

Dependencies added: servant-rawm-server

Dependencies removed: servant

Files

− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
breve.cabal view
@@ -1,5 +1,5 @@ name:                breve-version:             0.5.0.0+version:             0.5.1.0 synopsis:            a url shortener description: @@ -34,7 +34,7 @@                       DataKinds, KindSignatures, TypeOperators   build-depends:      base >=4.8 && <5.0,                       warp, warp-tls, tls, blaze-html,-                      servant, servant-server, servant-blaze,+                      servant-server, servant-rawm-server, servant-blaze,                       wai, wai-extra, streaming-commons, http-api-data,                        mtl, text, aeson, bytestring, binary,
src/Application.hs view
@@ -15,8 +15,9 @@ import Views  -- Misc-import Control.Monad.IO.Class  (liftIO)-import qualified Data.Text.IO  as T+import Control.Monad.IO.Class   (liftIO)+import Control.Monad.Reader     (ReaderT, runReaderT, asks)+import qualified Data.Text.IO   as T  -- JSON conversion import Data.Text                (Text)@@ -29,12 +30,25 @@  -- API definition import Servant-import Servant.HTML.Blaze       (HTML)-import Web.FormUrlEncoded       (FromForm(..), parseUnique)+import Servant.HTML.Blaze            (HTML)+import Web.FormUrlEncoded            (FromForm(..), parseUnique)+import qualified Servant.RawM.Server as R   -- * Types +-- | Custom handler type with a+-- reader environment+type AppM = ReaderT AppEnv Handler++-- | The environment associated+-- to 'AppM'+data AppEnv = AppEnv+  { bindUrl   :: Text+  , urlTable  :: UrlTable+  , staticDir :: FilePath+  }+ -- | API successful reply -- -- This is the reply returned by the JSON API@@ -82,7 +96,7 @@ -- +----------+------+----------------------+ type App =        Get '[HTML] Html-  :<|> "static" :> Raw+  :<|> "static" :> R.RawM   :<|> Capture "name" Name :> Redirect   :<|> ReqBody '[FormUrlEncoded] UrlForm :> Post '[HTML] Html @@ -97,11 +111,19 @@   "api" :> ReqBody '[FormUrlEncoded] UrlForm :> Post '[JSON] ApiReply  -- | Breve 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)+--+-- Notes:+--+-- * @api@ is an empty value that brings the type+-- 'Breve' to the 'serve' function. If Haskell were+-- depedently typed it would just be @serve Breve@+--+-- * hoistServer flattens the AppM monad stack+-- in the breveServer definition+breve :: AppEnv -> Application+breve env = serve api (hoistServer api nt breveServer)+  where api = Proxy :: Proxy Breve+        nt x = runReaderT x env  -- | Empty application --@@ -117,22 +139,26 @@ -- -- This is just an ordered collection of handlers -- following the 'Breve' API spec.-breveServer :: FilePath -> Url -> UrlTable -> Server Breve-breveServer static url table =-  api url table :<|> app-    where app = homepage                    :<|>-                serveDirectoryWebApp static :<|>-                resolver table              :<|>-                uploader url table+--+-- Note: 'RawM' is  required because Servant doesn't+-- allow the creation of a raw 'Application' from a+-- monadic value.+breveServer :: ServerT Breve AppM+breveServer = api :<|> app+  where app =  homepage+          :<|> (R.serveDirectoryWebApp =<< asks staticDir)+          :<|> resolver+          :<|> uploader  -- | Serves the homepage-homepage :: Handler Html+homepage :: AppM Html homepage = pure index  -- | Resolves a 'Name' to the full 'Url'-resolver :: UrlTable -> Name -> Handler Redirection-resolver table name = do-  url <- liftIO (extract table name)+resolver :: Name -> AppM Redirection+resolver name = do+  table <- asks urlTable+  url   <- liftIO (extract table name)   case url of     Nothing  ->       throwError $ err404 { errBody = renderHtml (message "404: not found") }@@ -143,19 +169,23 @@  -- | Takes a 'UrlForm' via POST -- and prints the shortned one-uploader :: Url -> UrlTable -> UrlForm -> Handler Html-uploader bindUrl table (UrlForm url) = do-  name <- liftIO (insert table url)+uploader :: UrlForm -> AppM Html+uploader (UrlForm url) = do+  table <- asks urlTable+  bind  <- asks bindUrl+  name  <- liftIO (insert table url)   logStr ("Registered " <> url <> " -> " <> name)-  pure (done $ bindUrl <> name)+  pure (done $ bind <> name)  -- | Takes a 'Url' via POST and returns -- the shortned one in an 'ApiReply' as JSON.-api :: Url -> UrlTable -> UrlForm -> Handler ApiReply-api bindUrl table (UrlForm url) = do-  name <- liftIO (insert table url)+api :: UrlForm -> AppM ApiReply+api (UrlForm url) = do+  table <- asks urlTable+  bind  <- asks bindUrl+  name  <- liftIO (insert table url)   logStr ("Registered " <> url <> " -> " <> name)-  pure $ ApiReply { link     = (bindUrl <> name)+  pure $ ApiReply { link     = (bind <> name)                   , name     = name                   , original = url                   }@@ -163,7 +193,7 @@ -- * Misc  -- | Handy function to log to stdout-logStr :: Text -> Handler ()+logStr :: Text -> AppM () logStr = liftIO . T.putStrLn . ("[breve] " <>)  -- | Verb that encodes an HTTP 302 redirection
src/Breve/Generator.hs view
@@ -9,6 +9,7 @@ , intHash ) where +import Control.Monad          (replicateM) import Control.Monad.State import System.Random import Crypto.Hash.SHA256     (hash)
src/Breve/Settings.hs view
@@ -8,6 +8,8 @@ , settings ) where +import Paths_breve (getDataFileName)+ import Control.Monad                  (when) import System.Environment             (lookupEnv) import System.Directory               (doesFileExist, getXdgDirectory, XdgDirectory(..))@@ -25,6 +27,7 @@   , bindPort    :: Int          -- ^ the port to bind to   , bindUrl     :: Text         -- ^ the url used to reach breve   , urlTable    :: FilePath     -- ^ path where to save the url table+  , staticDir   :: FilePath     -- ^ path of the static assets   , tlsSettings :: TLSSettings  -- ^ warp TLS settings   } @@ -56,14 +59,16 @@     url  = "https://" <> host <> port <> "/"    baseURL <- lookupDefault url config "baseurl"+  static <- getDataFileName "static/"    createEmptyIfMissing urls    return AppSettings-    { bindHost = host-    , bindPort = portnum-    , bindUrl  = baseURL-    , urlTable = urls+    { bindHost  = host+    , bindPort  = portnum+    , bindUrl   = baseURL+    , urlTable  = urls+    , staticDir = static     , tlsSettings = (tlsSettingsChain cert chain key)       { tlsAllowedVersions = [TLS12, TLS11]       , tlsCiphers = ciphersuite_strong
src/Main.hs view
@@ -7,27 +7,26 @@ module Main where  -- Breve modules-import Application     (breve, emptyApp)-import Breve.Settings+import Application     (AppEnv(..), breve, emptyApp)+import Breve.Settings  (AppSettings(..), settings) import Breve.UrlTable-import Paths_breve     (getDataFileName)  -- Data conversions-import Data.Text       (Text, unpack) import Data.String     (IsString(..)) import Data.Maybe      (listToMaybe)+import Data.Text       (unpack)  -- IO-import Control.Monad      (when, void)-import Control.Exception  as E -import Control.Concurrent (forkIO)-import System.Environment (getArgs)-import Data.Text.IO       as T+import Data.Text.IO        as T+import Control.Exception   as E+import Control.Monad       (when, void)+import Control.Concurrent  (forkIO)+import System.Environment  (getArgs)  -- Web server import Servant                      (Application) import Network.Wai.Handler.Warp     (run, defaultSettings, setPort, setHost)-import Network.Wai.Handler.WarpTLS  (runTLS, TLSSettings)+import Network.Wai.Handler.WarpTLS  (runTLS)  -- Middlewares import Network.Wai.Middleware.RequestLogger (logStdout)@@ -54,7 +53,6 @@   configPath               <- fmap listToMaybe getArgs   config@(AppSettings{..}) <- settings configPath   table                    <- load urlTable-  static                   <- getDataFileName "static/"    -- Redirect from HTTP to HTTPS when listening   -- on the standard port@@ -69,6 +67,9 @@   -- We use one here to add requests   let middlewares = logStdout +  -- The environment needed while running+  let env = AppEnv bindUrl table staticDir+   handle exit $ do     T.putStrLn ("Serving on " <> bindUrl)-    runApp config (middlewares $ breve static bindUrl table)+    runApp config (middlewares $ breve env)
src/Views.hs view
@@ -11,7 +11,7 @@  -- | The homepage index :: Html-index = template $ do+index = breveTemplate $ do   H.form ! method "POST" $ do     "your url:"     input ! type_ "text" ! name "url"@@ -21,20 +21,20 @@ -- submitted successfully. Takes the resulting -- url as an argument. done :: Text -> Html-done url = template $ do+done url = breveTemplate $ do   "here's your new link: "   a ! href (toValue url) $ (toHtml url)  -- | Displays a text message in the page center message :: Text -> Html-message = template . toHtml+message = breveTemplate . toHtml  -- | The main Breve template -- -- Takes HTML code and embeds it in the -- inner page container.-template :: Html -> Html-template fill =+breveTemplate :: Html -> Html+breveTemplate fill =   docTypeHtml $ do     H.head $ do       H.title "breve: url shortener"@@ -42,6 +42,7 @@       meta ! name "keywords" ! content "url, shortener"       meta ! name "author" ! content "Michele Guerini Rocco"       meta ! charset "utf-8"+      meta ! name "color-scheme" ! content "dark"       link ! rel "stylesheet" ! href "/static/main.css" ! type_ "text/css"       link ! rel "apple-touch-icon" ! href "static/icon-big.png"       link ! rel "icon" ! type_ "image/png" ! href "/static/icon-medium.png" ! sizes "96x96"