diff --git a/examples/Simple.hs b/examples/Simple.hs
deleted file mode 100644
index 15bc9fefb7ccf3d01c7bc6a4dab9feab5cd8e37e..0000000000000000000000000000000000000000
--- a/examples/Simple.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-{-|
-Module : Simple
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-Demonstration of a simple stateful web service built using Hikaru.
-
-Simple /= Easy /= Short. Happy reading.
--}
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ApplicativeDo #-}
-
-module Simple (main)
-where
- import Prelude
- import Control.Concurrent.MVar
- import Control.Monad.Reader
- import Data.Maybe
- import Data.Text (Text)
- import Hikaru
- import Lucid
- import Network.HTTP.Types.Header
- import Network.HTTP.Types.Status
- import Network.Wai
- import Network.Wai.Handler.Warp
- import Network.Wai.Middleware.RequestLogger
-
-
- -- Action ------------------------------------------------------------------
-
-
- -- |
- -- Our custom action monad allows us to inspect request,
- -- build response and consult the model at the same time.
- --
- newtype Action a
- = Action
- { unAction :: ReaderT DemoEnv IO a
- }
- deriving (Functor, Applicative, Monad, MonadIO)
-
- instance MonadAction Action where
- getActionEnv = Action (demoActionEnv <$> ask)
-
- instance MonadModel Action where
- getModelEnv = Action (demoModelEnv <$> ask)
-
-
- data DemoEnv
- = DemoEnv
- { demoActionEnv :: ActionEnv
- , demoModelEnv :: ModelEnv
- }
-
-
- -- Model -------------------------------------------------------------------
-
-
- class (MonadIO m) => MonadModel m where
- getModelEnv :: m ModelEnv
-
-
- data ModelEnv
- = ModelEnv
- { modelCounter :: MVar Word
- }
-
-
- makeModelEnv :: Word -> IO ModelEnv
- makeModelEnv n = ModelEnv <$> newMVar n
-
-
- countVisitor :: (MonadModel m) => m Word
- countVisitor = do
- counter <- modelCounter <$> getModelEnv
- liftIO $ do
- modifyMVar_ counter (return . succ)
- readMVar counter
-
-
- -- Dispatching -------------------------------------------------------------
-
-
- runAction :: ModelEnv -> Action () -> Application
- runAction me act = do
- respond $ \ae -> do
- runReaderT (unAction act) (DemoEnv ae me)
-
-
- makeApplication :: ModelEnv -> Application
- makeApplication me = do
- dispatch (runAction me) $ do
- -- Register nicer error handlers.
- handler NotFound handleNotFound
-
- -- Plug in a cool logging middleware.
- middleware $ logStdoutDev
-
- -- Negotiate content for the root page.
- route $ getRootHtmlR <$ get <* offerHTML
- route $ getRootTextR <$ get <* offerText
-
- -- Disable caching for all the following endpoints.
- wrapAction (defaultHeader hCacheControl "no-store" >>) $ do
- -- Return search results and repeat the form.
- route $ getSearchHtmlR <$ get </ "search"
- <* offerHTML
-
- -- Present a simple greeting page.
- route $ getHelloR <$ get </ "hello" <*> arg
- <* offerText
-
- -- Create an echoing JSON API.
- route $ postEchoR <$ post </ "api" </ "echo"
- <* offerJSON <* acceptJSON
-
-
- -- Handlers ----------------------------------------------------------------
-
-
- getRootHtmlR :: Action ()
- getRootHtmlR = do
- -- Update the counter.
- n <- countVisitor
-
- -- Present fancy HTML result.
- sendHTML $ do
- h1_ "Welcome!"
- p_ $ "You are " >> toHtml (show n) >> ". visitor!"
-
- form_ [action_ "/search", method_ "GET"] $ do
- view <- newForm "search" $ searchForm (Just "meaning of life")
- formView_ view
-
-
- getSearchHtmlR :: Action ()
- getSearchHtmlR = do
- sendHTML $ do
- (maybeQuery, view) <- getForm "search" (searchForm Nothing)
-
- h1_ "Search results"
- form_ [method_ "GET"] $ do
- formView_ view
-
- case maybeQuery of
- Nothing -> ""
- Just q -> do
- hr_ []
- h2_ $ toHtml q
- p_ "Sorry, no results found!"
-
-
- searchForm :: (Monad m) => Maybe Text -> FormT Text m (Maybe Text)
- searchForm q = do
- q' <- inputField "q" "Query" q
- _ <- button "search" "Search"
- return q'
-
-
- formView_ :: (MonadAction m, Localized l) => FormView l -> HtmlT m ()
- formView_ view = do
- forM_ (formElements view) $ \element ->
- case element of
- Button{..} -> do
- button_ [ id_ elemName
- , name_ elemName
- ] $ lc_ elemLabel
-
- InputField{..} -> do
- label_ [ for_ elemName ] $ do
- lc_ elemLabel
- ":"
-
- input_ [ id_ elemName
- , name_ elemName
- , value_ (fromMaybe "" elemValue)
- ]
-
-
- getRootTextR :: Action ()
- getRootTextR = do
- -- Update the counter.
- n <- countVisitor
-
- -- Present a plain textual result.
- sendString $ unlines [ "Welcome!"
- , "You are " <> show n <> ". visitor!"
- ]
-
-
- postEchoR :: Action ()
- postEchoR = sendJSON =<< getJSON
-
-
- getHelloR :: Text -> Action ()
- getHelloR name = sendText $ "Hello, " <> name <> "!"
-
-
- handleNotFound :: RequestError -> Text -> Action ()
- handleNotFound _exn msg = do
- setStatus status404
- sendHTML $ do
- h1_ "404 Not Found"
- p_ (toHtml msg)
-
-
- -- Serving -----------------------------------------------------------------
-
-
- main :: IO ()
- main = do
- putStrLn "Listening (port 5000) ..."
- model <- makeModelEnv 0
- run 5000 (makeApplication model)
-
-
--- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/hikaru.cabal b/hikaru.cabal
index f7e3958db8f5e3587321bcebd80aec16e8b54426..aeeb1dcfbea9738ba74bb906e2ccf38e25a1c31e 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -1,7 +1,7 @@
cabal-version: 3.0
name: hikaru
-version: 0.1.0.0
+version: 0.2.0.0
homepage: https://github.com/mordae/hikaru#readme
bug-reports: https://github.com/mordae/hikaru/issues
@@ -33,7 +33,9 @@ common common
default-extensions:
AllowAmbiguousTypes
+ BangPatterns
BlockArguments
+ ConstraintKinds
DataKinds
DefaultSignatures
DeriveGeneric
@@ -41,7 +43,6 @@ common common
EmptyDataDecls
FlexibleContexts
FlexibleInstances
- GADTs
GeneralizedNewtypeDeriving
ImportQualifiedPost
KindSignatures
@@ -50,12 +51,15 @@ common common
NamedFieldPuns
NoImplicitPrelude
OverloadedStrings
+ PolyKinds
RankNTypes
RecordWildCards
ScopedTypeVariables
StandaloneDeriving
TupleSections
TypeApplications
+ TypeFamilies
+ TypeOperators
UndecidableInstances
ghc-options:
@@ -68,7 +72,7 @@ common common
build-depends:
, aeson >=1.4 && <1.6
- , base >=4.13 && <4.16
+ , base >=4.13 && <5
, binary >=0.8 && <0.9
, bytestring >=0.10 && <0.12
, case-insensitive >=1.2 && <1.3
@@ -77,6 +81,7 @@ common common
, cryptonite >=0.26 && <0.29
, foreign-store >=0.2 && <0.3
, http-types >=0.12 && <0.13
+ , hvect >=0.4 && <0.5
, lucid >=2.9 && <2.10
, memory >=0.15 && <0.16
, mtl >=2.2 && <2.3
diff --git a/lib/Hikaru.hs b/lib/Hikaru.hs
index cb29de1990f8c69627812bf9e56cd1dd2b907aa2..4199def6e11616c403116f2741646871e12596d0 100644
--- a/lib/Hikaru.hs
+++ b/lib/Hikaru.hs
@@ -1,14 +1,14 @@
-{-|
-Module : Hikaru
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module re-exports other modules in the package.
--}
+-- |
+-- Module : Hikaru
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module re-exports other modules in the package.
+--
module Hikaru
(
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index e9670a4b89eee8cee1ef10cc31de99c3287ebf29..d7242b908b423e22491c71e839afb49e317fb437 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -1,15 +1,15 @@
-{-|
-Module : Hikaru.Action
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides a monad for reacting to user requests by
-building responses.
--}
+-- |
+-- Module : Hikaru.Action
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides a monad for reacting to user requests by
+-- building responses.
+--
module Hikaru.Action
( MonadAction(..)
@@ -87,7 +87,8 @@ module Hikaru.Action
, wsReceive
-- ** Errors
- , throwError
+ , abort
+ , abortMiddleware
-- ** Localization
, getLanguages
@@ -169,6 +170,24 @@ where
instance (MonadAction m) => MonadAction (HtmlT m)
+ -- |
+ -- Exception raised by 'abort'.
+ --
+ data AbortAction
+ = AbortAction
+ { status :: Status
+ , headers :: [Header]
+ , message :: Text
+ }
+ deriving (Show, Generic)
+
+ instance NFData AbortAction where
+ rnf AbortAction{status = Status{..}, ..} =
+ rnf (statusCode, statusMessage, headers, message)
+
+ instance Exception AbortAction
+
+
-- |
-- Obtain only the specific 'ActionEnv' field value.
--
@@ -522,8 +541,8 @@ where
--
-- Returns 'Data.ByteString.empty' once the whole body has been consumed.
--
- -- * Throws 'PayloadTooLarge' if reading next chunk would exceed
- -- the allotted request body limit. See 'setBodyLimit' for more.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
--
getBodyChunk :: (MonadAction m) => m ByteString
getBodyChunk = do
@@ -536,8 +555,8 @@ where
--
-- Returns 'Data.ByteString.empty' once the whole body has been consumed.
--
- -- * Throws 'PayloadTooLarge' if reading next chunk would exceed
- -- the allotted request body limit. See 'setBodyLimit' for more.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
--
getBodyChunkIO :: (MonadAction m) => m (IO ByteString)
getBodyChunkIO = do
@@ -555,12 +574,8 @@ where
return chunk
else do
- throwLimitIO limit
-
- where
- throwLimitIO :: Int64 -> IO a
- throwLimitIO n = throwIO (PayloadTooLarge, msg :: Text)
- where msg = "Limit is " <> tshow n <> " bytes."
+ abort requestEntityTooLarge413 []
+ ("Limit is " <> tshow limit <> " bytes.")
-- |
@@ -574,7 +589,8 @@ where
-- Using this function directly will prevent access to the body in other
-- ways, such as through the 'getJSON', 'getFields' or 'getFiles'.
--
- -- * Reading the body can throw 'PayloadTooLarge'.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
--
getBodyRaw :: (MonadAction m) => m LBS.ByteString
getBodyRaw = do
@@ -595,16 +611,16 @@ where
-- |
-- Read, parse, cache and return 'Value' sent by the user.
--
- -- * Throws 'UnsupportedMediaType' if the Content-Type does not
+ -- * Aborts with 'unsupportedMediaType415' if 'hContentType' does not
-- indicate a JSON payload.
--
- -- * Throws 'BadRequest' if the payload fails to parse.
+ -- * Aborts with 'badRequest400' if the payload fails to parse.
--
- -- * Throws 'PayloadTooLarge' if the payload size limit is exceeded.
- -- Use 'setBodyLimit' to adjust the limit to your liking.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
--
- -- * Throws 'InternalError' is the body has already been consumed
- -- and was not cached as JSON.
+ -- * Aborts with 'internalServerError500' if the body has already been
+ -- consumed and was not cached as JSON.
--
getJSON :: (MonadAction m, FromJSON a) => m a
getJSON = do
@@ -615,7 +631,7 @@ where
-- This is ideal, we already have what we need.
BodyJSON value ->
case fromJSON value of
- Data.Aeson.Error err -> throwError BadRequest (cs err)
+ Data.Aeson.Error err -> abort badRequest400 [] (cs err)
Data.Aeson.Success out -> return out
-- Body has not been parsed yet. This is very good.
@@ -624,7 +640,7 @@ where
if matchMediaList ctype [ "application/json", "text/json" ]
then return ()
- else throwError UnsupportedMediaType "Send some JSON!"
+ else abort unsupportedMediaType415 [] "Send some JSON!"
-- Taint and read.
setActionField aeBody BodyTainted
@@ -632,7 +648,7 @@ where
-- Try to parse.
value <- case eitherDecode' body of
- Left reason -> throwError BadRequest (cs reason)
+ Left reason -> abort badRequest400 [] (cs reason)
Right value -> return value
-- Cache and return.
@@ -640,13 +656,13 @@ where
-- Parse to the output type.
case fromJSON value of
- Data.Aeson.Error err -> throwError BadRequest (cs err)
+ Data.Aeson.Error err -> abort badRequest400 [] (cs err)
Data.Aeson.Success out -> return out
-- Now this is bad. We have already read the body,
-- but not as a JSON. This is an internal error.
_else -> do
- throwError InternalError "Body has been parsed as a non-JSON."
+ abort internalServerError500 [] "Body has been parsed as non-JSON."
-- |
@@ -656,13 +672,16 @@ where
-- uploades them to a temporary location and caches information
-- about them so that 'getFiles' can return them separately.
--
- -- * Throws 'UnsupportedMediaType' if the Content-Type does not
+ -- * Aborts with 'unsupportedMediaType415' if 'hContentType' does not
-- indicate a form payload.
--
- -- * Throws 'BadRequest' if the payload fails to parse.
+ -- * Aborts with 'badRequest400' if the payload fails to parse.
--
- -- * Throws 'PayloadTooLarge' if the payload size limit is exceeded.
- -- Use 'setBodyLimit' to adjust the limit to your liking.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
+ --
+ -- * Aborts with 'internalServerError500' if the body has already been
+ -- consumed and was not cached as form data.
--
getFields :: (MonadAction m) => m [(Text, Text)]
getFields = map cs2 <$> fst <$> getFormData
@@ -722,13 +741,16 @@ where
-- Backend for both 'getFields' and 'getFiles' that parses,
-- caches and returns form data.
--
- -- * Throws 'UnsupportedMediaType' if the Content-Type does not
+ -- * Aborts with 'unsupportedMediaType415' if 'hContentType' does not
-- indicate a form payload.
--
- -- * Throws 'BadRequest' if the payload fails to parse.
+ -- * Aborts with 'badRequest400' if the payload fails to parse.
--
- -- * Throws 'PayloadTooLarge' if the payload size limit is exceeded.
- -- Use 'setBodyLimit' to adjust the limit to your liking.
+ -- * Aborts with 'requestEntityTooLarge413' if reading next chunk would
+ -- exceed the allotted request body limit. See 'setBodyLimit' for more.
+ --
+ -- * Aborts with 'internalServerError500' if the body has already been
+ -- consumed and was not cached as form data.
--
getFormData :: (MonadAction m) => m FormData
getFormData = do
@@ -744,7 +766,7 @@ where
getChunk <- getBodyChunkIO
case bodyType of
- Nothing -> throwError UnsupportedMediaType "Send some form!"
+ Nothing -> abort unsupportedMediaType415 [] "Send some form!"
Just bt -> do
-- Prepare for uploaded files finalization.
rtis <- createInternalState
@@ -764,7 +786,7 @@ where
-- Now this is bad. We have already read the body,
-- but not as a form. This is an internal error.
_else -> do
- throwError InternalError "Body has been parsed as a non-form."
+ abort internalServerError500 [] "Body has been parsed as non-form."
-- |
@@ -810,7 +832,7 @@ where
-- Now this is bad. We have already read the body,
-- but not as a raw data. This is an internal error.
_else -> do
- throwError InternalError "Body has already been parsed."
+ abort internalServerError500 [] "Body has already been parsed."
-- Building Response -------------------------------------------------------
@@ -1107,7 +1129,7 @@ where
Just resp -> resp
_else -> do
- throwError InternalError "Body has already been consumed."
+ abort internalServerError500 [] "Body has already been consumed."
where
app :: WS.PendingConnection -> IO ()
@@ -1167,10 +1189,24 @@ where
-- |
- -- Same an IO exception in the form of ('RequestError', 'Text').
+ -- Raise 'AbortAction' using given status, headers and a textual body.
+ -- Headers are prefixed with ('hContentType', @text/plain@).
+ --
+ -- You are supposed to use it together with 'abortMiddleware' that turns
+ -- such exception into regular 'Response's.
+ --
+ abort :: (MonadIO m) => Status -> [Header] -> Text -> m a
+ abort st hdrs msg = throwIO $ AbortAction st hdrs' msg
+ where hdrs' = (hContentType, "text/plain; charset=utf8") : hdrs
+
+
+ -- |
+ -- Catches 'AbortAction' and turns it into a 'Response'.
--
- throwError :: (MonadAction m) => RequestError -> Text -> m a
- throwError exn msg = throwIO (exn, msg)
+ abortMiddleware :: Middleware
+ abortMiddleware app req sink = do
+ app req sink `catch` \AbortAction{..} -> do
+ sink $ responseLBS status headers (cs message)
-- Localization ------------------------------------------------------------
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index 1f07c29ce7235180a1ce8aaaa02cd0983611f221..7252242050dfe53a235cee7b73ba47a567f247c6 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -1,14 +1,14 @@
-{-|
-Module : Hikaru.CSRF
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides CSRF mitigation utilities.
--}
+-- |
+-- Module : Hikaru.CSRF
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides CSRF mitigation utilities.
+--
module Hikaru.CSRF
( generateToken
diff --git a/lib/Hikaru/Develop.hs b/lib/Hikaru/Develop.hs
index a6a34d2ac6c0df0cedf49831eabd6e658db3da50..8129f818a9b60ca8d301c1ce86bbe23351d43161 100644
--- a/lib/Hikaru/Develop.hs
+++ b/lib/Hikaru/Develop.hs
@@ -1,14 +1,14 @@
-{-|
-Module : Hikaru.Develop
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides development and testing utilities.
--}
+-- |
+-- Module : Hikaru.Develop
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides development and testing utilities.
+--
module Hikaru.Develop
( developWith
diff --git a/lib/Hikaru/Dispatch.hs b/lib/Hikaru/Dispatch.hs
index e82bc370361c3ac3f8fdfbfacd803e240aed742a..5a8c0d6114d495211ffd491cdb2aaab706a2fea3 100644
--- a/lib/Hikaru/Dispatch.hs
+++ b/lib/Hikaru/Dispatch.hs
@@ -1,247 +1,168 @@
-{-|
-Module : Hikaru.Dispatch
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides monad-based request dispatching.
--}
+-- |
+-- Module : Hikaru.Dispatch
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides means for dispatching on routes.
+--
+-- For example:
+--
+-- @
+-- demo :: 'Application'
+-- demo = 'dispatch' id do
+-- 'middleware' logStdout
+-- 'handler' 404 notFound
+-- 'route' getHelloR
+-- 'route' getByeR
+-- @
+--
module Hikaru.Dispatch
- ( dispatch
-
- -- ** Routes
+ ( Dispatch
+ , dispatch
, route
- , wrapRoute
- , wrapRoutes
- , wrapAction
- , wrapActions
-
- -- ** Middleware
, middleware
-
- -- ** Error Handlers
, handler
-
- -- * Types
- , Dispatch
- , Nested
- , TopLevel
)
where
- import Praha
+ import Praha hiding (curry)
- import Control.Monad.State
- import Data.CaseInsensitive (original)
- import Data.List (lookup, deleteBy, intersperse, reverse, map)
+ import Hikaru.Action (abortMiddleware)
import Hikaru.Route
- import Hikaru.Types
+
+ import Network.HTTP.Types.Status
import Network.HTTP.Types.Header
import Network.Wai
- import UnliftIO.Exception
- import qualified Data.Map.Strict as Map
+ import Data.List (reverse, lookup, sortOn)
-- |
- -- Monad for the 'dispatch' function.
+ -- Since routes do not share a common type (due to their captured parameters
+ -- being part of their type), we cannot just pass them in a list. So for
+ -- convenience, there is a dispatcher monad that also helps with middleware
+ -- and error handler registration.
--
- newtype Dispatch r l a
+ newtype Dispatch h a
= Dispatch
- { unDispatch :: State (Env r) a
+ { runDispatch :: State (Env h) a
}
deriving (Functor, Applicative, Monad)
- -- |
- -- Part of the top-level 'Dispatch' signature.
- --
- data TopLevel
-
-
- -- |
- -- Part of the nested 'Dispatch' signature.
- --
- data Nested
-
-
- data Env r
+ data Env h
= Env
- { envRouteWrap :: Route r -> Route r
- , envActionWrap :: r -> r
- , envHandlers :: Map RequestError (RequestError -> Text -> r)
- , envMiddleware :: Middleware
- , envRoutes :: [Route r] -- in reverse order
+ { routes :: [Request -> Maybe (h, Score)]
+ , mwstack :: Middleware
+ , handlers :: [(Int, Response -> h)]
}
- initEnv :: Env r
- initEnv = Env id id mempty id mempty
+ initEnv :: Env h
+ initEnv = Env { routes = []
+ , mwstack = id
+ , handlers = []
+ }
-- |
- -- Create an application out of routes, handlers and middleware.
- --
- -- You can use 'route', 'handler', 'middleware' to register each of
- -- these components respectively.
- --
- -- @
- -- app :: Application
- -- app = dispatch runAction $ do
- -- 'middleware' $ logStdoutDev
- --
- -- 'route' $ getRootR \<$ 'Hikaru.Route.get'
- -- 'route' $ getHelloR \<$ 'Hikaru.Route.get' \<\/ "hello" \<*\> 'arg'
+ -- Try to dispatch on a route.
--
- -- 'wrapRoute' needAuth $ do
- -- 'route' $ getAdminR \<$ 'Hikaru.Route.get' \<\/ "admin"
- -- 'route' $ postPassR \<$ 'Hikaru.Route.post' \<\/ "admin" \<\/ "password"
+ -- All routes are tried and scored for every request,
+ -- preferring the earlier one in case of a tie.
--
- -- 'handler' 'NotFound' notFoundR
- -- @
- --
- dispatch :: forall r. (r -> Application)
- -> forall a. Dispatch r TopLevel a
- -> Application
- dispatch runner = build runner . flip execState initEnv . unDispatch
-
-
- build :: forall r. (r -> Application) -> Env r -> Application
- build runner Env{..} = envMiddleware app'
- where
- app' req resp = mw app req resp
- where
- (mw, app) = case selectRoute (reverse envRoutes) req of
- RouteFailed exn msg vhs -> (addVary vhs, err exn msg)
- RouteSuccess ac _qu vhs -> (addVary vhs, run ac)
-
- run :: r -> Application
- run x req' resp' = catch (runner x req' resp')
- (\(exn, msg) -> mw (err exn msg) req' resp')
+ route :: Route (ts :: [Type]) h -> Dispatch h ()
+ route r = Dispatch do
+ let r' req = case routeApply (pathInfo req) r of
+ Just h -> Just (h, routeScore req r)
+ Nothing -> Nothing
- err :: RequestError -> Text -> Application
- err exn msg = case Map.lookup exn envHandlers of
- Just eh -> runner (eh exn msg)
- Nothing -> defaultHandler exn msg
+ -- Routes must be prepended since we will later sort them and
+ -- reverse the order, making the earlier matching routes come
+ -- out first.
+ modify \e@Env{..} -> e { routes = r' : routes }
-- |
- -- Make sure that the @Vary@ response header contains specified names.
+ -- Register middleware.
--
- addVary :: [HeaderName] -> Middleware
- addVary vs = if vs == [] then id else apply
- where
- apply = modifyResponse (mapResponseHeaders fixup)
- fixup = modifyHeader "Vary" (maybe value (<> ", " <> value))
- value = mconcat $ intersperse ", " $ map original vs
-
- modifyHeader n fn hs = (n, v') : Data.List.deleteBy headerEq (n, v') hs
- where v' = fn (Data.List.lookup n hs)
-
- headerEq (x, _) (y, _) = x == y
+ -- Middleware gets applied in the reverse order of its appearence,
+ -- but always after the error handler.
+ --
+ middleware :: Middleware -> Dispatch h ()
+ middleware mw = Dispatch do
+ modify \e@Env{..} -> e { mwstack = mwstack . mw }
-- |
- -- Register a route.
+ -- Register error handler.
--
- -- When multiple routes match with the same quality coefficient,
- -- the one registered first will be selected.
+ -- It gets called when some of the routes respond with given status code.
+ -- Middleware gets applied after the handler, not before.
--
- route :: Route r -> Dispatch r l ()
- route rt = Dispatch do
- modify \env@Env{..} ->
- env { envRoutes = envRouteWrap (fmap envActionWrap rt) : envRoutes }
+ handler :: Int -> (Response -> h) -> Dispatch h ()
+ handler code fn = Dispatch do
+ modify \e@Env{..} -> e { handlers = (code, fn) : handlers }
-- |
- -- Wrap all nested routes with a route transformer.
+ -- Perform the dispatching.
+ --
+ -- Needs a runner function that converts whatever saturated routes produce
+ -- into a regular WAI 'Application'.
--
- -- It is a little bit similar to the middleware, but route-specific and
- -- with full access to the routing utilities. Can be used e.g. to apply
- -- authentication to multiple routes at once or to update their content
- -- negotiation parameters.
+ -- If no route matches or matching routes all fail during appraisal, an
+ -- error response gets generated. It is extremely simple, @text/plain@
+ -- response with the status code and message repeated in the body.
+ -- You can register your own 'handler', though.
--
- wrapRoute :: (Route r -> Route r) -> Dispatch r Nested a -> Dispatch r l ()
- wrapRoute wrapper disp = Dispatch do
- modify \env ->
- let env' = execState (unDispatch disp)
- (env { envRouteWrap = envRouteWrap env . wrapper })
+ dispatch :: (h -> Application) -> Dispatch h a -> Application
+ dispatch run Dispatch{runDispatch} req = do
+ let Env{..} = execState runDispatch initEnv
- in env { envRoutes = envRoutes env' <> envRoutes env }
+ let good = mapMaybe ($ req) routes
+ best = reverse (sortOn snd good)
+ let app = case best of
+ (h, Suitable _):_ -> run h
+ (_, reason):_ -> err reason
+ [] -> err NotFound
- -- |
- -- Wrap all /following/ routes with a route transformer.
- --
- wrapRoutes :: (Route r -> Route r) -> Dispatch r l ()
- wrapRoutes wrapper = Dispatch do
- modify \env -> env { envRouteWrap = envRouteWrap env . wrapper }
+ let mwstack' = mwstack . handlerMW run handlers . abortMiddleware
+ mwstack' app req
- -- |
- -- Wrap all nested actions with an action transformer.
- --
- wrapAction :: (r -> r) -> Dispatch r Nested a -> Dispatch r l ()
- wrapAction wrapper disp = Dispatch do
- modify \env ->
- let env' = execState (unDispatch disp)
- (env { envActionWrap = envActionWrap env . wrapper })
- in env { envRoutes = envRoutes env' <> envRoutes env }
+ err :: Score -> Application
+ err BadRequest = respond status400
+ err NotFound = respond status404
+ err MethodNotAllowed = respond status405
+ err UpgradeRequired = respond status426
+ err NotAcceptable = respond status406
+ err LengthRequired = respond status411
+ err UnsupportedMediaType = respond status415
+ err (Suitable _) = error "BUG: errored out with a Suitable"
- -- |
- -- Wrap all /following/ actions with an action transformer.
- --
- -- This can come in handy e.g. to tune cache control:
- --
- -- @
- -- app :: Application
- -- app = 'dispatch' runAction $ do
- -- 'wrapRoutes' ('Hikaru.Action.defaultHeader' hCacheControl "no-cache" >>)
- --
- -- 'route' $ getRootR \<$ 'Hikaru.Route.get'
- -- 'route' $ getHelloR \<$ 'Hikaru.Route.get' \<\/ "hello" \<*\> 'arg'
- -- @
- --
- wrapActions :: (r -> r) -> Dispatch r l ()
- wrapActions wrapper = Dispatch do
- modify \env -> env { envActionWrap = envActionWrap env . wrapper }
+ respond :: Status -> Application
+ respond st@Status{..} _ sink = sink $ responseLBS st hdr msg
+ where
+ hdr = [(hContentType, "text/plain")]
+ msg = cs (show statusCode) <> " " <> cs statusMessage
- -- |
- -- Register a middleware.
- --
- -- They are applied in the reverse order of their registation,
- -- i.e. the first one to be registered is the last one to be applied.
- --
- -- Middleware can only be registered at the top level of the dispatcher.
- --
- middleware :: Middleware -> Dispatch r TopLevel ()
- middleware mw = Dispatch do
- modify \env@Env{envMiddleware} ->
- env { envMiddleware = envMiddleware . mw }
+ handlerMW :: (h -> Application) -> [(Int, Response -> h)] -> Middleware
+ handlerMW run handlers app req sink = do
+ app req \resp -> do
+ let Status{..} = responseStatus resp
- -- |
- -- Register a 'RequestError' handler.
- --
- -- The handler is passed the original request and is supposed to
- -- inform the user about the issue. It should use the correct HTTP
- -- status code.
- --
- -- If you need to perform content negotiation in the handler,
- -- you can use 'dispatch' in it as well. Just make sure to provide a
- -- route that cannot fail.
- --
- handler :: RequestError
- -> (RequestError -> Text -> r)
- -> Dispatch r TopLevel ()
- handler e h = Dispatch do
- modify \env@Env{envHandlers} ->
- env { envHandlers = Map.insert e h envHandlers }
+ case lookup statusCode handlers of
+ Just fn -> run (fn resp) req sink
+ Nothing -> sink resp
-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index 8ffac6168aed4de39d969b7ce101a5d29c55eafe..f3cae9b1c7ae4eeb67ea0a6ceebe39520da3e211 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -1,29 +1,28 @@
-{-|
-Module : Hikaru.Form
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides tools for building localized HTML forms
-with server-side validation.
-
-There are three important steps involved:
-
-1. A 'Form' needs to be defined first. For that you need to supply the
- underlying data type as well as high-level description of the form
- elements.
-
-2. It needs be fed some request data. You control what data by using
- 'newForm', 'getForm' or 'postForm'.
-
-3. It needs to be rendered as HTML. This module will leave you with a
- high-level form 'View', but you need to take care of the rendering
- yourself.
-
--}
+-- |
+-- Module : Hikaru.Form
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides tools for building localized HTML forms
+-- with server-side validation.
+--
+-- There are three important steps involved:
+--
+-- 1. A 'Form' needs to be defined first. For that you need to supply the
+-- underlying data type as well as high-level description of the form
+-- elements.
+--
+-- 2. It needs be fed some request data. You control what data by using
+-- 'newForm', 'getForm' or 'postForm'.
+--
+-- 3. It needs to be rendered as HTML. This module will leave you with a
+-- high-level form 'View', but you need to take care of the rendering
+-- yourself.
+--
module Hikaru.Form
(
@@ -118,7 +117,9 @@ where
, envValue :: Maybe o
, envValidate :: Bool
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData o) => NFData (Env o)
-- |
@@ -132,7 +133,9 @@ where
{ viewElements :: [Element l]
, viewControls :: [Control l]
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (View l)
-- |
@@ -190,7 +193,9 @@ where
{ elemLabel :: l
, elemControls :: [Control l]
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (Element l)
-- |
@@ -228,7 +233,10 @@ where
, ctrlNotes :: [Note l]
, ctrlHints :: [Dynamic]
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (Control l) where
+ rnf Control{..} = rnf (ctrlName, ctrlField, ctrlNotes)
data ControlState l v m
@@ -239,6 +247,10 @@ where
, csValidators :: [Maybe v -> m [Note l]]
, csValue :: Maybe v
}
+ deriving (Generic)
+
+ instance (NFData l, NFData v) => NFData (ControlState l v m) where
+ rnf ControlState{..} = rnf (csName, csField, csValidators, csValue)
instance (Show l, Show v) => Show (ControlState l v m) where
show ControlState{..} =
@@ -267,9 +279,7 @@ where
lift = ControlT . lift . lift
{-# INLINE lift #-}
- instance (MonadAction m) => MonadAction (ControlT t l o v m) where
- getActionEnv = ControlT $ lift $ lift $ getActionEnv
- {-# INLINE getActionEnv #-}
+ instance (MonadAction m) => MonadAction (ControlT t l o v m)
-- |
@@ -281,7 +291,9 @@ where
{ noteSeverity :: Severity
, noteMessage :: l
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (Note l)
-- |
@@ -299,7 +311,9 @@ where
| SelectField
{ fieldOptions :: [Option l]
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (Field l)
-- |
@@ -308,7 +322,9 @@ where
data FieldTag
= InputFieldTag
| SelectFieldTag
- deriving (Show, Eq)
+ deriving (Show, Eq, Generic)
+
+ instance NFData FieldTag
-- |
@@ -320,7 +336,9 @@ where
, optionSelected :: Bool
, optionValue :: Text
}
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance (NFData l) => NFData (Option l)
class ToOption l o where
@@ -380,7 +398,9 @@ where
data FormMessage
= FormMsgFieldRequired
| FormMsgTokenInvalid
- deriving (Show)
+ deriving (Show, Generic)
+
+ instance NFData FormMessage
instance Localizable FormMessage where
-- Czech strings
diff --git a/lib/Hikaru/Link.hs b/lib/Hikaru/Link.hs
index e991ec8c90431aec90254af4d24f53155c2a5460..eae4ab15f9ce71737273f849c27e31bb2cc52bec 100644
--- a/lib/Hikaru/Link.hs
+++ b/lib/Hikaru/Link.hs
@@ -1,127 +1,114 @@
-{-|
-Module : Hikaru.Link
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides various ways to build local links and provide
-feedback based on the request path.
--}
+-- |
+-- Module : Hikaru.Link
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides various ways to build local links and provide
+-- feedback based on the request path.
+--
module Hikaru.Link
- ( makeLink
- , deriveLink
-
- -- ** Lucid Integration
- , lhref_
- , phref_
- , qhref_
-
- -- ** Path Feedback
- , isActivePath
- , isActivePrefix
+ ( rhref
+ , rhref_
+ , updateQuery
+ , isActiveRoute
)
where
- import Praha
+ import Praha hiding (curry)
+
+ import Hikaru.Action
+ import Hikaru.Route
+ import Hikaru.Types
+
+ import Network.HTTP.Types.URI
import Data.Binary.Builder
+ import Data.List (map, filter)
+ import Data.Maybe (isJust)
+
+ import Data.HVect
+
import Lucid
- import Network.HTTP.Types.URI
- import Hikaru.Action
- import Data.List (isPrefixOf, map, filter)
-- |
- -- Combine path segments and parameters to create an internal Link.
+ -- Construct a link with a query string to the given route,
+ -- using given values for captured segments.
--
- -- Examples:
+ -- Example:
--
- -- >>> makeLink ["api", "echo"] []
- -- "/api/echo"
- -- >>> makeLink ["char", ""] [("name", "haruhi")]
- -- "/char/?name=haruhi"
+ -- >>> rhref getEchoR "Hi" [("q", "42")]
+ -- "/echo/Hi?q=42"
--
- makeLink :: [Text] -> [(Text, Text)] -> Text
- makeLink ps qs = cs $ toLazyByteString $ encodePath ps $ csQueryTuple qs
+ rhref :: (HasRep ts, AllHave Param ts)
+ => Route ts a
+ -> HVectElim ts ([(Text, Text)] -> Text)
+ rhref route = curry (hvRhref route)
+
+
+ hvRhref :: (AllHave Param ts)
+ => Route ts a -> HVect ts -> [(Text, Text)] -> Text
+ hvRhref route xs qs = buildLink route xs qs
-- |
- -- Create a link with just the query string by updating the
- -- parameters sent by the client.
+ -- Similar to 'rhref', but inteded to be used with Lucid.
--
- -- All keys that appear in the new parameter list are first deleted
- -- from the current parameter list, then the new list is appended to
- -- the current one.
+ -- Example:
--
- -- Useful to create dynamic pages with multiple independent widgets.
+ -- @
+ -- qs <- updateQuery [("conv", "upper")]
+ -- 'a_' ['rhref_' getEchoR "Hi" qs] ...
+ -- @
--
- deriveLink :: (MonadAction m) => [(Text, Text)] -> m Text
- deriveLink ps = do
- ops <- getParams
- return $ makeLink [] $ update ops ps
+ rhref_ :: (HasRep ts, AllHave Param ts)
+ => Route ts a
+ -> HVectElim ts ([(Text, Text)] -> Attribute)
+ rhref_ route = curry (hvRhref_ route)
- csQueryTuple :: [(Text, Text)] -> [(ByteString, Maybe ByteString)]
- csQueryTuple = map \(n, v) -> (cs n, Just (cs v))
+ hvRhref_ :: (AllHave Param ts)
+ => Route ts a -> HVect ts -> [(Text, Text)] -> Attribute
+ hvRhref_ route xs qs = href_ (buildLink route xs qs)
- update :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
- update old new = deleteNewKeys old <> new
+ buildLink :: (AllHave Param ts)
+ => Route ts a -> HVect ts -> [(Text, Text)] -> Text
+ buildLink route xs qs = cs (toLazyByteString (path <> query))
where
- deleteNewKeys = filter \(n, _) -> n `notElem` newKeys
- newKeys = map fst new
+ path = case routeLinkHVect route xs of
+ [] -> "/"
+ ps -> encodePathSegments ps
-
- -- Lucid Integration -------------------------------------------------------
+ query = renderQueryBuilder True $
+ flip map qs \(n, v) -> (cs n, Just (cs v))
-- |
- -- Create a @href@ attribute using 'makeLink'.
+ -- Update query string from the original request with supplied values.
--
- lhref_ :: [Text] -> [(Text, Text)] -> Attribute
- lhref_ ps qs = href_ (makeLink ps qs)
- {-# INLINE lhref_ #-}
-
-
- -- |
- -- Same as 'lhref_', but without any query parameters.
+ -- First, all keys in the supplied query are removed from the original,
+ -- then the supplied query gets appended to the original.
--
- phref_ :: [Text] -> Attribute
- phref_ ps = href_ (makeLink ps [])
- {-# INLINE phref_ #-}
-
-
- -- |
- -- Same as 'lhref_', but without any path components.
- --
- qhref_ :: [(Text, Text)] -> Attribute
- qhref_ qs = href_ (makeLink [] qs)
- {-# INLINE qhref_ #-}
+ updateQuery :: (MonadAction m) => [(Text, Text)] -> m [(Text, Text)]
+ updateQuery query' = do query <- filter (not. updated) <$> getParams
+ return (query <> query')
+ where
+ updated (key, _) = key `elem` map fst query'
-- Path Feedback -----------------------------------------------------------
-- |
- -- Determine whether the supplied path is the one user has requested.
- --
- isActivePath :: (MonadAction m) => [Text] -> m Bool
- isActivePath link = do
- path <- getPathInfo
- return $ link == path
-
-
- -- |
- -- Determine whether the supplied path is a prefix of the one user has
- -- requested. Empty path components in the supplied path are ignored.
+ -- Determine whether the supplied route is the one user has requested.
--
- isActivePrefix :: (MonadAction m) => [Text] -> m Bool
- isActivePrefix link = do
- path <- getPathInfo
- return $ isPrefixOf (filter (/= "") link) path
+ isActiveRoute :: (MonadAction m) => Route ts a -> m Bool
+ isActiveRoute route = isJust <$> flip routeApply route <$> getPathInfo
-- vim:set ft=haskell sw=2 ts=2 et:
diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs
index 0ea3a4fd59a6cb6b058848e18d635b57d4a8c65e..3c540316911aa2cab22471a41cddfa561ffea925 100644
--- a/lib/Hikaru/Localize.hs
+++ b/lib/Hikaru/Localize.hs
@@ -1,60 +1,60 @@
-{-|
-Module : Hikaru.Localize
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides support for website localization.
-
-First, you need to create a message catalog:
-
-@
--- All messages we want to localize.
-data SampleMessages
- = MsgSuccess
- | MsgFailure
- deriving (Show)
-
--- Default HTML rendering of the messages.
-instance 'ToHtml' SampleMessages where
- 'toHtmlRaw' = 'toHtml'
-
--- Language-specific rendering of those messages.
-instance Localizable SampleMessages where
- -- English variants
- 'localize' \"en\" MsgSuccess = 'Just' \"Success\"
- 'localize' \"en\" MsgFailure = 'Just' \"Failure\"
-
- -- Czech variants
- 'localize' \"cs\" MsgSuccess = 'Just' \"Úspěch\"
- 'localize' \"cs\" MsgFailure = 'Just' \"Selhání\"
-
- -- Otherwise try the next locale
- 'localize' _locale _msg = 'Nothing'
-@
-
-Next, create a preferred language list for every action:
-
-@
-'Hikaru.Dispatch.dispatch' runAction $ do
- 'Hikaru.Dispatch.wrapAction' ('selectLanguages' \"lang\" \"lang\" >>) $ do
- 'Hikaru.Dispatch.route' ...
-@
-
-Finally, you can use your catalog when rendering pages:
-
-@
-getSampleR :: 'Bool' -> Action ()
-getSampleR flag = do
- 'sendHTML' $ do
- if flag
- then lc_ MsgSuccess
- else lc_ MsgFailure
-@
--}
+-- |
+-- Module : Hikaru.Localize
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides support for website localization.
+--
+-- First, you need to create a message catalog:
+--
+-- @
+-- -- All messages we want to localize.
+-- data SampleMessages
+-- = MsgSuccess
+-- | MsgFailure
+-- deriving (Show)
+--
+-- -- Default HTML rendering of the messages.
+-- instance 'ToHtml' SampleMessages where
+-- 'toHtmlRaw' = 'toHtml'
+--
+-- -- Language-specific rendering of those messages.
+-- instance Localizable SampleMessages where
+-- -- English variants
+-- 'localize' \"en\" MsgSuccess = 'Just' \"Success\"
+-- 'localize' \"en\" MsgFailure = 'Just' \"Failure\"
+--
+-- -- Czech variants
+-- 'localize' \"cs\" MsgSuccess = 'Just' \"Úspěch\"
+-- 'localize' \"cs\" MsgFailure = 'Just' \"Selhání\"
+--
+-- -- Otherwise try the next locale
+-- 'localize' _locale _msg = 'Nothing'
+-- @
+--
+-- Next, create a preferred language list for every action:
+--
+-- @
+-- 'Hikaru.Dispatch.dispatch' runAction $ do
+-- 'Hikaru.Dispatch.wrapAction' ('selectLanguages' \"lang\" \"lang\" >>) $ do
+-- 'Hikaru.Dispatch.route' ...
+-- @
+--
+-- Finally, you can use your catalog when rendering pages:
+--
+-- @
+-- getSampleR :: 'Bool' -> Action ()
+-- getSampleR flag = do
+-- 'sendHTML' $ do
+-- if flag
+-- then lc_ MsgSuccess
+-- else lc_ MsgFailure
+-- @
+--
module Hikaru.Localize
( Locale
@@ -157,8 +157,8 @@ where
preferred <- getParamMaybe paramName
previous <- getCookieMaybe cookieName
acceptable <- getAcceptLanguage
- <&> filter ((> 0) . mediaQuality)
- <&> map mediaMainType
+ <&> filter ((> 0) . quality)
+ <&> map mainType
case preferred of
Nothing -> return ()
diff --git a/lib/Hikaru/Media.hs b/lib/Hikaru/Media.hs
index 0b045c35e8424fc2652db9ee17c442d638cecc45..028d13da5b23b9ddadc26e96a4f1500282703ae1 100644
--- a/lib/Hikaru/Media.hs
+++ b/lib/Hikaru/Media.hs
@@ -1,16 +1,16 @@
-{-|
-Module : Hikaru.Media
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides means for parsing HTTP media lists that can be found
-in the headers such as @Accept@, @Accept-Charset@, @Accept-Encoding@ and
-@Accept-Language@.
--}
+-- |
+-- Module : Hikaru.Media
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides means for parsing HTTP media lists that can be found
+-- in headers such as @Accept@, @Accept-Charset@, @Accept-Encoding@ and
+-- @Accept-Language@.
+--
module Hikaru.Media
( Media(..)
@@ -29,7 +29,7 @@ where
import Data.Text (toLower)
- import Data.List (filter, lookup, head, sortOn)
+ import Data.List (filter, lookup, sortOn)
import Text.ParserCombinators.ReadP
import Data.Char (isControl, isSpace)
@@ -38,23 +38,27 @@ where
-- Single media element.
--
-- When used for media without a subtype (such as languages or encodings),
- -- the respective field is just @""@ while quality defaults to @1.0@.
+ -- the subType field is just @""@ while quality defaults to @1.0@.
--
data Media
= Media
- { mediaMainType :: Text
- , mediaSubType :: Text
- , mediaParams :: [(Text, Text)]
- , mediaQuality :: Float
+ { mainType :: Text
+ , subType :: Text
+ , params :: [(Text, Text)]
+ , quality :: Float
}
- deriving (Show, Eq, Ord)
+ deriving (Show, Eq, Ord, Generic)
+
+ instance NFData Media
-- |
-- You can construct media elements using @OverloadedStrings@.
-- Just be careful - invalid syntax means a runtime error.
--
instance IsString Media where
- fromString = head . parseMedia . cs
+ fromString str = case parseMedia (cs str) of
+ m:_ -> m
+ _else -> error $ "Failed to parse media " <> show str
-- |
@@ -64,13 +68,13 @@ where
-- Example:
--
-- >>> parseMedia "text/html, text/plain;q=0.7"
- -- [ Media { mediaMainType = "text", mediaSubType = "html", mediaQuality = 1.0 }
- -- , Media { mediaMainType = "text", mediaSubType = "plain", mediaQuality = 0.7 }
+ -- [ Media { mainType = "text", subType = "html", quality = 1.0, params = [] }
+ -- , Media { mainType = "text", subType = "plain", quality = 0.7, params = [] }
-- ]
--
parseMedia :: Text -> [Media]
parseMedia text = case readP_to_S pMediaList (cs (toLower text)) of
- (m, ""):_ -> sortOn (negate . mediaQuality) m
+ (m, ""):_ -> sortOn (negate . quality) m
_else -> []
@@ -82,14 +86,14 @@ where
pMediaList = sepBy pMedia pSeparator <* eof
where
pMedia = do
- mediaMainType <- cs <$> pToken
- _ <- char '/'
- mediaSubType <- cs <$> pToken
- mediaParams <- many pParameter
+ mainType <- cs <$> pToken
+ _ <- char '/'
+ subType <- cs <$> pToken
+ params <- many pParameter
- let mediaQuality = fromMaybe 1.0 do
- q <- lookup "q" mediaParams
- readMaybe (cs q)
+ let quality = fromMaybe 1.0 do
+ q <- lookup "q" params
+ readMaybe (cs q)
return Media{..}
@@ -129,13 +133,10 @@ where
-- False
--
matchMedia :: Media -> Media -> Bool
- matchMedia l r = mainMatches && subMatches && mediaQuality r > 0.0
+ matchMedia l r = mainMatches && subMatches && quality r > 0.0
where
- mainMatches = mediaMainType l == mediaMainType r
- || mediaMainType r == "*"
-
- subMatches = mediaSubType l == mediaSubType r
- || mediaSubType r == "*"
+ mainMatches = mainType l == mainType r || mainType r == "*"
+ subMatches = subType l == subType r || subType r == "*"
-- |
@@ -161,9 +162,9 @@ where
selectMedia :: [Media] -> [Media] -> Maybe Media
selectMedia ls rs = case best of
[ ] -> Nothing
- (l, r):_ -> Just $ l { mediaQuality = mediaQuality r }
+ (l, r):_ -> Just $ l { quality = quality r }
where
- best = sortOn (negate . mediaQuality . snd) good
+ best = sortOn (negate . quality . snd) good
good = filter (uncurry matchMedia) prod
prod = [(l, r) | l <- ls, r <- rs]
diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs
index 200cd667d87aa1b69decea44ca9ed422377bcb9e..a51b7b420f5b1620d4baece142c01e59e142d829 100644
--- a/lib/Hikaru/Route.hs
+++ b/lib/Hikaru/Route.hs
@@ -1,396 +1,373 @@
-{-|
-Module : Hikaru.Route
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides path matching with parameter extraction
-as well as content negotiation through path quality scoring.
--}
+-- |
+-- Module : Hikaru.Route
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- This module provides means for route construction.
+--
module Hikaru.Route
- (
- -- * Route Selection
- selectRoute
- , RouteResult(..)
-
- -- ** Path Matching
- , seg
- , (</)
- , arg
- , argWith
- , rest
-
- -- ** Route Scoring
- , vary
- , score
+ ( -- * Path Matching
+ Route
+ , root
+ , (/:)
+ , (//)
+ , (/?)
+
+ -- * Route Scoring
+ , Appraisal(..)
, Score(..)
- -- *** Method
+ -- ** Method (HTTP Verb)
, method
, get
, post
- , head
- , put
- , patch
- , delete
- -- *** WebSockets
+ -- ** WebSockets
+ , requireWebsocket
, websocket
- -- *** Request Content
+ -- ** Request Content
, acceptContent
, acceptForm
, acceptJSON
- -- *** Response Content
+ -- ** Response Content
, offerContent
, offerHTML
, offerText
, offerJSON
- , offerCharset
, offerEncoding
, offerLanguage
- -- ** Types
- , Route
+ -- * Applying Routes
+ , routePath
+ , PathInfo(..)
+ , routeLink
+ , routeLinkHVect
+ , routeApply
+ , routeScore
+ , routeVary
)
where
- import Praha
-
- import Data.List (lookup, map)
+ import Praha hiding (curry)
import Hikaru.Media
import Hikaru.Types
+
import Network.HTTP.Types.Header
- import Network.HTTP.Types.Method (Method)
import Network.Wai
import Network.Wai.Handler.WebSockets
+ import Data.List (reverse, nub, lookup)
+ import Data.Typeable (TypeRep, typeRep)
+
+ import Data.HVect hiding (reverse)
+
-- |
- -- 'Applicative' used to associate a handler with conditions,
- -- upon which to invoke it.
+ -- Route combines path description with a handler that gets saturated
+ -- with captured path components.
+ --
+ -- Just make a path like this:
+ --
+ -- @
+ -- getHelloR :: 'Route' \'[Text, Text] Text
+ -- getHelloR = 'get' handler '//' \"hello\" '/:' \"greeting\" '/:' \"name\"
+ -- where handler greeting name = mconcat [ greeting, \", \", name, \"!\" ]
+ -- @
+ --
+ -- And then apply it to a list of path components, like that:
+ --
+ -- >>> routeApply ["hello", "What a nice day", "dear Reader"] getHelloR
+ -- Just "What a nice day, dear Reader!"
--
- -- Frequent conditions include HTTP method and path matching,
- -- but can also include an arbitrary 'Request' inspection
+ -- Or construct a link to it with 'routeLink':
--
- newtype Route a
+ -- >>> href getHelloR "Ahoy" "Sailor"
+ -- ["hello", "Ahoy", Sailor"]
+ --
+ -- Or better yet, use 'Hikaru.Dispatch.dispatch' to select the best
+ -- route to handle a 'Request'.
+ --
+ data Route ts a
= Route
- { runRoute :: Env -> (Env, Maybe a)
+ { path :: [PathInfo]
+ , func :: [Text] -> Maybe a
+ , score :: [Request -> Score]
+ , vary :: [HeaderName]
}
+ deriving (Generic)
- instance Functor Route where
- fmap f r = Route \env -> fmap (fmap f) (runRoute r env)
- {-# INLINE fmap #-}
-
- instance Applicative Route where
- pure x = Route \env -> (env, Just x)
- {-# INLINE pure #-}
+ instance NFData (Route ts a)
- (<*>) rf rx = Route \env ->
- case runRoute rf env of
- (env', Just f) -> runRoute (fmap f rx) env'
- (env', Nothing) -> case runRoute rx env' of
- (env'', _) -> (env'', Nothing)
- {-# INLINE (<*>) #-}
+ data PathInfo
+ = Segment Text
+ -- ^ Path segment to be matched.
+ | Capture Text TypeRep
+ -- ^ Path segment to be captured.
+ deriving (Show, Eq, Generic)
- -- |
- -- Internal 'Route' environment.
- --
- data Env
- = Env
- { envPath :: [Text]
- -- ^ Remaining path segments to consume during matching.
-
- , envScoring :: [Request -> Score]
- -- ^ Registered scoring functions to select the best handler.
-
- , envVary :: [HeaderName]
- -- ^ List of headers used to score this route.
- }
+ instance NFData PathInfo
-- |
- -- Route scoring result.
- --
- -- Scores are ordered in the descending order of preference.
+ -- Indicates suitability as well as quality of a route.
--
- -- Route matching results in the worst result encountered in the route.
- -- Dispatcher then selects the route with the best score overall.
- -- Best match does not necessarily mean a successfull one, though.
+ -- Scores form a monoid, added together the smaller one wins.
+ -- When two Suitable ones are added, their quality gets multiplied.
+ -- Since the default quality is 1.0 and quality (when negotiating content)
+ -- should be in the \((0.0, 1.0]\) range, this helps to select appropriate
+ -- route across multiple appraisals.
--
data Score
- = Suitable !Float
- | Unsuitable !RequestError Text
- deriving (Eq, Ord)
+ = BadRequest
+ | NotFound
+ | MethodNotAllowed
+ | UpgradeRequired
+ | NotAcceptable
+ | LengthRequired
+ | UnsupportedMediaType
+ | Suitable Float
+ -- ^ Suitable routes have quality.
+ deriving (Show, Eq, Ord, Generic)
+
+ instance NFData Score
-
- -- |
- -- Concatenating two scores produces the worse one.
- -- If both are suitable, the quality is multiplied.
- --
instance Semigroup Score where
(Suitable x) <> (Suitable y) = Suitable (x * y)
- x <> y = max x y
- {-# INLINE (<>) #-}
+ x <> y = min x y
- -- |
- -- Results form a monoid with 'Suitable' as the neutral element.
- --
instance Monoid Score where
mempty = Suitable 1.0
- {-# INLINE mempty #-}
-- |
- -- Result of a route matching.
+ -- Appraisal of a route to decide whether it's suitable for a 'Request'
+ -- or not.
--
- -- * 'RequestError' is used to indicate the reason of failure.
+ -- Some appraisals (especially those for content negotiation) inspect
+ -- request headers. HTTP spec mandates that any 'Response' that serves
+ -- different content based on headers (e.g. in a different language) to
+ -- always include a @Vary@ header with names of all headers used in this
+ -- manner. You can get the list for a route using 'routeVary'.
--
- -- * Successfull value is annotated with headers used to select it
- -- and the final quality. You should send them to the user using
- -- the @Vary@ header.
+ -- You should mention those headers when designing your own appraisals,
+ -- by the way.
--
- data RouteResult a
- = RouteFailed
- { rresError :: RequestError
- , rresMessage :: Text
- , rresVary :: [HeaderName]
+ data Appraisal
+ = Appraisal
+ { score :: Request -> Score
+ , vary :: [HeaderName]
}
- | RouteSuccess
- { rresAction :: a
- , rresQuality :: Float
- , rresVary :: [HeaderName]
- }
-
- -- |
- -- It forms a semigroup that selects the best result overall.
- --
- instance Semigroup (RouteResult a) where
- x@(RouteSuccess _ g _) <> y@(RouteSuccess _ h _) = if g >= h then x else y
- x@(RouteSuccess _ _ _) <> ( RouteFailed _ _ _) = x
- ( RouteFailed _ _ _) <> y@(RouteSuccess _ _ _) = y
- x@(RouteFailed g _ _) <> y@(RouteFailed h _ _) = if g >= h then x else y
+ deriving (Generic)
+ instance NFData Appraisal
- -- |
- -- Given a list of available routes and a 'Request'
- -- return the action to take or give a reason for failure.
- --
- selectRoute :: [Route a] -> Request -> RouteResult a
- selectRoute rs req = choosePath req $ mapMaybe bind rs
- where bind = flip bindPath (pathInfo req)
+ type family RouteElim (r :: Type) (ts :: [Type]) where
+ RouteElim r (t ': ts) = t -> RouteElim r ts
+ RouteElim r '[] = r
- -- |
- -- Map action to path components.
- --
- bindPath :: Route a -> [Text] -> Maybe (Request -> RouteResult a)
- bindPath rt p = case runRoute (rt <* end) (Env p [] []) of
- (_, Nothing) -> Nothing
- (env, Just x) -> Just (scoreResult env x)
+ infixl 4 /:
-- |
- -- Score the mapped action with respect to the request.
+ -- Extends the route with a captured component that gets automatically
+ -- converted using 'fromParam' behind the scenes when saturating
+ -- the handler.
--
- scoreResult :: Env -> a -> Request -> RouteResult a
- scoreResult Env{..} x req =
- case mconcat (map (req &) envScoring) of
- Unsuitable exn msg -> RouteFailed exn msg envVary
- Suitable score' -> if score' <= 0.0
- then RouteFailed NotAcceptable "" envVary
- else RouteSuccess x score' envVary
-
-
- -- |
- -- Select the best route with respect to the request.
+ -- The 'Text' argument itself can be obtained using 'routePath' later,
+ -- when you want to introspect the route for some reason. It serves no
+ -- other purpose.
--
- choosePath :: Request -> [Request -> RouteResult a] -> RouteResult a
- choosePath req = choose . map ($ req)
+ (/:) :: forall ts a b. (Param a, Typeable a)
+ => Route ts (a -> b) -> Text -> Route (Reverse (a ': Reverse ts)) b
+ (/:) r@Route{..} name = r { path = capture : path
+ , func = apply
+ }
where
- choose :: [RouteResult a] -> RouteResult a
- choose [] = RouteFailed NotFound "" []
- choose (r:rs) = sconcat (r :| rs)
+ capture = Capture name (typeRep proxy)
+ proxy = Proxy :: Proxy a
+ apply (this:rest) = func rest <*> fromParam this
+ apply _otherwise = Nothing
- -- Path Matching -----------------------------------------------------------
+ infixl 4 //
-- |
- -- Match and return following path segment.
+ -- Extends the route with a matched component.
--
- -- Fails with 'NotFound' if the segment is missing or different.
- --
- seg :: Text -> Route Text
- seg s = argWith \t -> if s == t
- then Just t
- else Nothing
+ (//) :: Route ts a -> Text -> Route ts a
+ (//) r@Route{..} seg = r { path = Segment seg : path
+ , func = apply
+ }
+ where
+ apply (this:rest) = if this == seg then func rest else Nothing
+ apply _otherwise = Nothing
- -- |
- -- Shortcut to append a path segment in a more readable way.
- --
- (</) :: Route a -> Text -> Route a
- (</) r t = r <* seg t
+ infixl 4 /?
-- |
- -- Match, parse and return following path segment.
- --
- -- Fails with 'NotFound' if the segment is missing or unparseable.
+ -- Extends the route with an appraisal. That is, an additional condition
+ -- (apart from path) that the route must satisfy in order to be used when
+ -- dispatching or with 'routeScore'.
--
- arg :: (Param a) => Route a
- arg = argWith fromParam
+ (/?) :: Route ts a -> Appraisal -> Route ts a
+ (/?) r@Route{..} Appraisal{score = score', vary = vary'} =
+ r { vary = nub (vary' <> vary)
+ , score = score' : score
+ }
-- |
- -- Match, parse and return next path segment using the supplied function.
- --
- -- Fails with 'NotFound' if the segment is missing.
- -- Otherwise respects the result of the matcher function.
+ -- Ties an empty path to an unsaturated handler.
--
- argWith :: (Text -> Maybe a) -> Route a
- argWith match =
- Route \env@Env{..} ->
- case envPath of
- [] -> (env, Nothing)
- (x:xs) -> (env { envPath = xs }, match x)
+ root :: handler -> Route '[] handler
+ root x = Route { path = []
+ , score = []
+ , vary = []
+ , func = \case
+ [] -> Just x
+ _else -> Nothing
+ }
-- |
- -- Match and return all remaining path segments.
+ -- Check that the request used given HTTP verb.
--
- rest :: Route [Text]
- rest = Route \env@Env{..} -> (env { envPath = [] }, Just envPath)
+ method :: ByteString -> Appraisal
+ method verb = Appraisal {vary = [], score}
+ where
+ score req = if requestMethod req == verb
+ then Suitable 1.0
+ else MethodNotAllowed
-- |
- -- Match end of the path (i.e. no remaining segments).
- -- Used to ensure that the path has been exhausted.
- --
- -- Fails with 'NotFound' if more segments are remaining.
+ -- Combines 'root' with 'method' for the most common case.
--
- end :: Route ()
- end = Route \env@Env{..} ->
- case envPath of
- [] -> (env, Just ())
- _ -> (env, Nothing)
+ get :: handler -> Route '[] handler
+ get fn = root fn /? method "GET"
-- |
- -- Score route with respect to the request using the supplied function.
+ -- Combines 'root' with 'method' for the second most common case.
--
- score :: (Request -> Score) -> Route ()
- score fn =
- Route \env@Env{..} ->
- (env { envScoring = fn : envScoring }, Just ())
+ post :: handler -> Route '[] handler
+ post fn = root fn /? method "POST"
-- |
- -- Add list of headers that have been inspected in order to
- -- select proper response format.
+ -- Check that the request wants to perform an upgrade to WebSocket.
--
- -- This is needed to ensure our responses are cached properly by any
- -- proxies along the way, but you only need to use this function if
- -- your action performs some kind of additional content negotiation.
- -- All the scoring functions in this module do this automatically.
+ -- Varies with 'hUpgrade'.
--
- vary :: [HeaderName] -> Route ()
- vary hs =
- Route \env@Env{..} ->
- (env { envVary = hs <> envVary }, Just ())
-
-
- -- Methods -----------------------------------------------------------------
+ requireWebsocket :: Appraisal
+ requireWebsocket = Appraisal {vary = [hUpgrade], score}
+ where
+ score req = if isWebSocketsReq req
+ then Suitable 1.0
+ else UpgradeRequired
-- |
- -- Match a particular HTTP method.
+ -- Combines 'root' with 'requireWebsocket' for a common case.
--
- -- Fails with 'MethodNotAllowed' if a different method was used.
- --
- method :: Method -> Route ()
- method meth = score \req ->
- if meth == requestMethod req
- then Suitable 1.0
- else Unsuitable MethodNotAllowed ""
+ websocket :: a -> Route '[] a
+ websocket fn = root fn /? requireWebsocket
-- |
- -- Same as 'method' with the @GET@ argument.
+ -- Return information about matched and captured path components
+ -- for given route. Might come in handy for automated API docs.
--
- get :: Route ()
- get = method "GET"
+ routePath :: Route ts a -> [PathInfo]
+ routePath Route{path} = reverse path
-- |
- -- Same as 'method' with the @POST@ argument.
+ -- Apply route to a path, ideally resulting in a saturated handler.
--
- post :: Route ()
- post = method "POST"
+ routeApply :: [Text] -> Route ts a -> Maybe a
+ routeApply xs Route{func} = func (reverse xs)
-- |
- -- Same as 'method' with the @HEAD@ argument.
+ -- Score route for given 'Request'.
--
- head :: Route ()
- head = method "HEAD"
+ routeScore :: Request -> Route ts a -> Score
+ routeScore req Route{score} = mconcat $ fmap ($ req) score
-- |
- -- Same as 'method' with the @PUT@ argument.
+ -- Get list of all headers 'routeScore' would use.
--
- put :: Route ()
- put = method "PUT"
+ routeVary :: Route ts a -> [HeaderName]
+ routeVary Route{vary} = vary
-- |
- -- Same as 'method' with the @PATCH@ argument.
+ -- Construct link for the given route using supplied values of captured
+ -- path components. Useful to create hrefs and form actions.
--
- patch :: Route ()
- patch = method "PATCH"
+ routeLink :: forall ts a. (HasRep ts, AllHave Param ts)
+ => Route ts a -> HVectElim ts [Text]
+ routeLink route = curry (routeLinkHVect route)
-- |
- -- Same as 'method' with the @DELETE@ argument.
+ -- Same as 'routeLink', but operates on a heterogenous vector instead.
+ -- Useful to create your own 'routeLink'-like functions.
+ -- See 'curry' for more.
--
- delete :: Route ()
- delete = method "DELETE"
+ routeLinkHVect :: forall ts a. (AllHave Param ts)
+ => Route ts a -> HVect ts -> [Text]
+ routeLinkHVect Route{path} = buildPath (reverse path)
- -- |
- -- Match a WebSocket upgrade request.
- --
- websocket :: Route ()
- websocket = score \req ->
- if isWebSocketsReq req
- then Suitable 1.0
- else Unsuitable BadRequest "WebSocket Upgrade Expected"
+ buildPath :: forall ts. (AllHave Param ts)
+ => [PathInfo] -> HVect ts -> [Text]
+ buildPath [] _ = []
+ buildPath (Segment seg : more) xs = seg : buildPath more xs
+ buildPath (Capture _ _ : more) (x :&: xs) = toParam x : buildPath more xs
+ buildPath _ HNil = error "BUG: buildPath ran out of captures"
-- |
-- Check that the content sent by the client is among the listed
-- media types and fail with 'UnsupportedMediaType' if not.
- -- Adds @Vary: Content-Type@.
--
- acceptContent :: [Media] -> Route ()
- acceptContent media =
- vary [hContentType] <* score \req ->
- let header = parseMedia (cs $ getContentType req)
- in case selectMedia media header of
- Nothing -> Unsuitable UnsupportedMediaType ""
- Just md -> Suitable (mediaQuality md)
+ -- Varies with 'hContentType'.
+ --
+ acceptContent :: [Media] -> Appraisal
+ acceptContent media = Appraisal {vary = [hContentType], score}
+ where
+ score req = do
+ let header = parseMedia (cs $ getContentType req)
+
+ case selectMedia media header of
+ Just Media{..} -> Suitable quality
+ Nothing -> UnsupportedMediaType
-- |
-- Shortcut to accept only form submissions.
--
- acceptForm :: Route ()
+ -- @
+ -- acceptForm = acceptContent [ \"application/x-www-form-urlencoded\"
+ -- , \"multipart/form-data\"
+ -- ]
+ -- @
+ --
+ acceptForm :: Appraisal
acceptForm = acceptContent [ "application/x-www-form-urlencoded"
, "multipart/form-data"
]
@@ -399,7 +376,13 @@ where
-- |
-- Shortcut to accept only JSON documents.
--
- acceptJSON :: Route ()
+ -- @
+ -- acceptJSON = acceptContent [ \"application/json\"
+ -- , \"text/json\"
+ -- ]
+ -- @
+ --
+ acceptJSON :: Appraisal
acceptJSON = acceptContent [ "application/json"
, "text/json"
]
@@ -407,76 +390,86 @@ where
-- |
-- Check that we can send an acceptable response to the client and
- -- fail with 'NotAcceptable' if not. Add @Vary: Accept@.
+ -- fail with 'NotAcceptable' if not.
+ --
+ -- Varies with 'hAccept'.
--
- offerContent :: [Media] -> Route ()
- offerContent media =
- vary [hAccept] <* score \req ->
- let header = parseMedia (cs $ getAccept req)
- in case selectMedia media header of
- Nothing -> Unsuitable NotAcceptable ""
- Just md -> Suitable (mediaQuality md)
+ offerContent :: [Media] -> Appraisal
+ offerContent media = Appraisal {vary = [hAccept], score}
+ where
+ score req = do
+ let header = parseMedia (cs $ getAccept req)
+
+ case selectMedia media header of
+ Just Media{..} -> Suitable quality
+ Nothing -> NotAcceptable
-- |
-- Shortcut to offer HTML replies only.
--
- offerHTML :: Route ()
+ -- @
+ -- offerHTML = offerContent [\"text/html\"]
+ -- @
+ --
+ offerHTML :: Appraisal
offerHTML = offerContent ["text/html"]
-- |
-- Shortcut to offer plain text replies only.
--
- offerText :: Route ()
+ -- @
+ -- offerText = offerContent [\"text/plain\"]
+ -- @
+ --
+ offerText :: Appraisal
offerText = offerContent ["text/plain"]
-- |
-- Shortcut to offer JSON replies only.
--
- offerJSON :: Route ()
- offerJSON = offerContent ["application/json"]
-
-
- -- |
- -- Check that we can send an acceptable charset to the client and
- -- fail with 'NotAcceptable' if not. Add @Vary: Accept-Charset@.
+ -- @
+ -- offerJSON = offerContent [\"application/json\"]
+ -- @
--
- offerCharset :: [Media] -> Route ()
- offerCharset media =
- vary [hAcceptCharset] <* score \req ->
- let header = parseMedia (cs $ getAcceptCharset req)
- in case selectMedia media header of
- Nothing -> Unsuitable NotAcceptable ""
- Just md -> Suitable (mediaQuality md)
+ offerJSON :: Appraisal
+ offerJSON = offerContent ["application/json"]
-- |
-- Check that we can send an acceptable encoding to the client and
- -- fail with 'NotAcceptable' if not. Add @Vary: Accept-Encoding@.
+ -- fail with 'NotAcceptable' if not.
--
- offerEncoding :: [Media] -> Route ()
- offerEncoding media =
- vary [hAcceptEncoding] <* score \req ->
- let header = parseMedia (cs $ getAcceptEncoding req)
- in case selectMedia media header of
- Nothing -> Unsuitable NotAcceptable ""
- Just md -> Suitable (mediaQuality md)
+ -- Varies with 'hAcceptEncoding'.
+ --
+ offerEncoding :: [Media] -> Appraisal
+ offerEncoding media = Appraisal {vary = [hAcceptEncoding], score}
+ where
+ score req = do
+ let header = parseMedia (cs $ getAcceptEncoding req)
+
+ case selectMedia media header of
+ Just Media{..} -> Suitable quality
+ Nothing -> NotAcceptable
-- |
-- Check that we can send an acceptable language to the client and
- -- fail with 'NotAcceptable' if not. Add @Vary: Accept-Language@.
+ -- fail with 'NotAcceptable' if not.
--
- offerLanguage :: [Media] -> Route ()
- offerLanguage media =
- vary [hAcceptLanguage] <* score \req ->
- let header = parseMedia (cs $ getAcceptLanguage req)
- in case selectMedia media header of
- Nothing -> Unsuitable NotAcceptable ""
- Just md -> Suitable (mediaQuality md)
+ -- Varies with 'hAcceptLanguage'.
+ --
+ offerLanguage :: [Media] -> Appraisal
+ offerLanguage media = Appraisal {vary = [hAcceptLanguage], score}
+ where
+ score req = do
+ let header = parseMedia (cs $ getAcceptLanguage req)
+ case selectMedia media header of
+ Just Media{..} -> Suitable quality
+ Nothing -> NotAcceptable
-- Request Utilities -------------------------------------------------------
@@ -495,13 +488,6 @@ where
getAccept = fromMaybe "*/*" . getHeader hAccept
- -- |
- -- Obtain the Accept-Charset header value or the default value of \"*\".
- --
- getAcceptCharset :: Request -> ByteString
- getAcceptCharset = fromMaybe "*" . getHeader hAcceptCharset
-
-
-- |
-- Obtain the Accept-Encoding header value or the default
-- value of \"identity,*;q=0\".
diff --git a/lib/Hikaru/Types.hs b/lib/Hikaru/Types.hs
index 7cb9e8221fd49313e450227a53385c3db5dcb953..c94821330a2b7a17889f7fb024683582fdf34fc9 100644
--- a/lib/Hikaru/Types.hs
+++ b/lib/Hikaru/Types.hs
@@ -1,36 +1,26 @@
-{-|
-Module : Hikaru.Types
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-This module provides types common for multiple other modules.
--}
+-- |
+-- Module : Hikaru.Types
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
module Hikaru.Types
( Param(..)
- , RequestError(..)
, Severity(..)
- , defaultHandler
)
where
import Praha
- import Data.ByteString (ByteString)
- import Data.Text (pack, unpack)
- import Network.HTTP.Types.Header
- import Network.HTTP.Types.Status
- import Network.Wai
-
+ import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.Text.Encoding
import qualified Data.Text.Encoding.Error
import qualified Data.Text.Lazy
-
-- |
-- Types that can be parsed from a route segment or a query string
-- parameter into some kind of value. One does not usually pass around
@@ -48,101 +38,101 @@ where
{-# INLINE toParam #-}
instance Param Int where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Int8 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Int16 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Int32 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Int64 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Word where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Word8 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Word16 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Word32 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Word64 where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Integer where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Natural where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Float where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param Double where
- fromParam = readMaybe . unpack
+ fromParam = readMaybe . cs
{-# INLINE fromParam #-}
- toParam = pack . show
+ toParam = cs . show
{-# INLINE toParam #-}
instance Param () where
@@ -175,12 +165,12 @@ where
{-# INLINE toParam #-}
instance Param Char where
- fromParam inp = case (unpack inp) of
+ fromParam inp = case (cs inp) of
[x] -> Just x
_else -> Nothing
{-# INLINE fromParam #-}
- toParam char = pack [char]
+ toParam char = cs [char]
{-# INLINE toParam #-}
instance Param String where
@@ -228,104 +218,6 @@ where
{-# INLINE toParam #-}
- -- |
- -- Errors used both by "Hikaru.Action" and "Hikaru.Route"
- -- to report problems with the requests sent by the user.
- --
- -- Order by the severity from the least to the most severe.
- --
- data RequestError
- = TooManyRequests
- -- ^ The user has sent too many requests in a given amount of time.
- | PreconditionRequired
- -- ^ Server requires the request to be conditional.
- | Unprocessable
- -- ^ The request was well-formed but had some semantic errors.
- | ExpectationFailed
- -- ^ Expectation indicated by the Expect header can't be met.
- | RangeNotSatisfiable
- -- ^ The range specified by the Range header can't be fulfilled.
- | UnsupportedMediaType
- -- ^ Request payload format is not supported by the server.
- | PayloadTooLarge
- -- ^ Request entity is larger than limits defined by server.
- | PreconditionFailed
- -- ^ The client has indicated preconditions in its headers which
- -- the server does not meet.
- | LengthRequired
- -- ^ Content-Length header field is mandatory but missing.
- | Gone
- -- ^ Requested content has been permanently deleted from server,
- -- with no forwarding address.
- | Conflict
- -- ^ Request conflicts with the current state of the server.
- | NotAcceptable
- -- ^ After performing content negotiation, no content following
- -- the criteria given by the user agent has remained.
- | MethodNotAllowed
- -- ^ The request method is not available for the resource.
- | NotFound
- -- ^ Requested resource could not be found.
- | Forbidden
- -- ^ The client does not have access rights to the content.
- -- Unlike 'Unauthorized', the client's identity is known to
- -- the server.
- | Unauthorized
- -- ^ Client must authenticate itself to get the requested response.
- | BadRequest
- -- ^ The request was not well-formed.
- | ServiceUnavailable
- -- ^ The server is not ready to handle the request.
- | InternalError
- -- ^ The server has encountered a situation it doesn't know
- -- how to handle.
- deriving (Eq, Ord, Show, Typeable)
-
- -- |
- -- Adding two errors chooses the less severe one.
- --
- instance Semigroup RequestError where
- (<>) = min
- {-# INLINE (<>) #-}
-
- -- |
- -- Request errors can be thrown and catched, when accompanied with
- -- a short message.
- --
- instance Exception (RequestError, Text)
-
-
- -- |
- -- Default handlers for when user did not register a custom one.
- --
- defaultHandler :: RequestError -> Text -> Application
- defaultHandler meth msg _ resp =
- case meth of
- TooManyRequests -> response status429 "420 Too Many Requests"
- PreconditionRequired -> response status428 "428 Precondition Required"
- Unprocessable -> response status422 "422 Unprocessable"
- ExpectationFailed -> response status417 "417 Expectation Failed"
- RangeNotSatisfiable -> response status416 "416 Range Not Satisfiable"
- UnsupportedMediaType -> response status415 "415 Unsupported Media Type"
- PayloadTooLarge -> response status413 "413 Payload Too Large"
- PreconditionFailed -> response status412 "412 Precondition Failed"
- LengthRequired -> response status411 "411 Length Required"
- Gone -> response status410 "410 Gone"
- Conflict -> response status409 "409 Conflict"
- NotAcceptable -> response status406 "406 Not Acceptable"
- Forbidden -> response status403 "403 Forbidden"
- Unauthorized -> response status401 "401 Unauthorized"
- BadRequest -> response status400 "400 Bad Request"
- ServiceUnavailable -> response status503 "503 Service Unavailable"
- InternalError -> response status500 "500 Internal Server Error"
- MethodNotAllowed -> response status405 "405 Method Not Allowed"
- NotFound -> response status404 "404 Not Found"
-
- where
- response st = resp . responseLBS st [(hContentType, "text/plain")]
- . cs . (\str -> if msg == "" then str else msg)
-
-
-- |
-- Information severity to be used for messages.
--
@@ -333,7 +225,9 @@ where
= Success
| Warning
| Danger
- deriving (Eq, Ord, Enum, Show)
+ deriving (Eq, Ord, Enum, Show, Generic)
+
+ instance NFData Severity
-- |
-- Concatenation yields the higher severity.
diff --git a/lib/Hikaru/Widget.hs b/lib/Hikaru/Widget.hs
index 60906b8f4d534e3768eab003233ac2529b13be6c..d3ac9d9bd81d3398a39be837f7fa3450ff7494e8 100644
--- a/lib/Hikaru/Widget.hs
+++ b/lib/Hikaru/Widget.hs
@@ -148,8 +148,7 @@ where
}
deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
- instance (MonadAction m) => MonadAction (WidgetT m) where
- getActionEnv = lift getActionEnv
+ instance (MonadAction m) => MonadAction (WidgetT m)
-- |
diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs
index 77c72cf73d42269a6804a7ae4db74b75826e0944..2def3760b77acc88f1a340c9a80e034923a6ff03 100644
--- a/test/Hikaru/Demo.hs
+++ b/test/Hikaru/Demo.hs
@@ -1,12 +1,12 @@
-{-|
-Module : Hikaru.Demo
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
--}
+-- |
+-- Module : Hikaru.Demo
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
module Hikaru.Demo
( makeDemo
@@ -14,9 +14,10 @@ module Hikaru.Demo
where
import Praha hiding (for_)
+ import Hikaru
+
import UnliftIO.MVar
import Data.Aeson (Value)
- import Hikaru
import Lucid
import Network.HTTP.Types.Header
import Network.HTTP.Types.Status
@@ -50,6 +51,8 @@ where
, demoModelEnv :: ModelEnv
}
+ type Handler = Action ()
+
-- Model -------------------------------------------------------------------
@@ -101,130 +104,142 @@ where
makeDemo :: IO Application
makeDemo = do
model <- makeModelEnv 0
- cfg <- configFromEnv
- return $ makeApplication model cfg
+ return $ makeApplication model
- runAction :: ModelEnv -> Config -> Action () -> Application
- runAction me cfg act = do
- respond cfg \ae -> do
+ runAction :: ModelEnv -> Action () -> Application
+ runAction me act = do
+ respond \ae -> do
runReaderT (unAction act) (DemoEnv ae me)
- makeApplication :: ModelEnv -> Config -> Application
- makeApplication me cfg = do
- dispatch (runAction me cfg) do
+ makeApplication :: ModelEnv -> Application
+ makeApplication me = do
+ dispatch (runAction me) do
-- Register nicer 404 error handler.
- handler NotFound handleNotFound
+ handler 404 notFound
-- Negotiate content for the root page.
- route $ getRootHtmlR <$ get <* offerHTML
- route $ getRootTextR <$ get <* offerText
+ route getRootHtmlR
+ route getRootTextR
+
+ -- Present a simple greeting page.
+ route getHelloR
- -- Disable caching for these endpoints:
- wrapAction (defaultHeader hCacheControl "no-store" >>) do
- -- Present a simple greeting page.
- route $ getHelloR <$ get </ "hello" <*> arg
- <* offerText
+ -- Present an echoing JSON API.
+ route postEchoR
- -- Present an echoing JSON API.
- route $ postEchoR <$ post </ "api" </ "echo"
- <* offerJSON <* acceptJSON
+ -- Handle new cases.
+ route postCaseR
- -- Handle new cases.
- route $ postCaseR <$ post </ "case" </ ""
- <* acceptForm
+ -- Handle case listing.
+ route getCasesR
- -- Handle case listing.
- route $ getCasesR <$ get </ "case" </ ""
- <* offerJSON
+ -- Routes ------------------------------------------------------------------
- -- Handlers ----------------------------------------------------------------
+ getRootHtmlR :: Route '[] Handler
+ getRootHtmlR = get handle /? offerHTML
+ where
+ handle = do
+ -- Update the counter.
+ n <- countVisitor
- getRootHtmlR :: Action ()
- getRootHtmlR = do
- -- Update the counter.
- n <- countVisitor
+ -- Present fancy HTML result.
+ sendHTML do
+ h1_ "Welcome!"
+ p_ $ "You are " >> toHtml (tshow n) >> ". visitor!"
- -- Present fancy HTML result.
- sendHTML do
- h1_ "Welcome!"
- p_ $ "You are " >> toHtml (tshow n) >> ". visitor!"
+ getRootTextR :: Route '[] Handler
+ getRootTextR = get handle /? offerText
+ where
+ handle = do
+ -- Update the counter.
+ n <- countVisitor
- getRootTextR :: Action ()
- getRootTextR = do
- -- Update the counter.
- n <- countVisitor
+ -- Present a plain textual result.
+ sendText $ unlines [ "Welcome!"
+ , "You are " <> tshow n <> ". visitor!"
+ ]
- -- Present a plain textual result.
- sendText $ unlines [ "Welcome!"
- , "You are " <> tshow n <> ". visitor!"
- ]
+ postEchoR :: Route '[] Handler
+ postEchoR = post handle // "api" // "echo" /? offerJSON /? acceptJSON
+ where
+ handle = do
+ setHeader hCacheControl "no-store"
+ (json :: Value) <- getJSON
+ sendJSON json
- postEchoR :: Action ()
- postEchoR = do
- (json :: Value) <- getJSON
- sendJSON json
+ getHelloR :: Route '[Text] Handler
+ getHelloR = get handle // "hello" /: "name" /? offerText
+ where
+ handle name = do
+ setHeader hCacheControl "no-store"
- getHelloR :: Text -> Action ()
- getHelloR name = sendText $ "Hello, " <> name <> "!"
+ when (name == "nobody") do
+ abort badRequest400 [] "I don't like you."
+ sendText $ "Hello, " <> name <> "!"
- handleNotFound :: RequestError -> Text -> Action ()
- handleNotFound _exn msg = do
+
+ notFound :: Response -> Action ()
+ notFound _resp = do
setStatus status404
- sendHTML do
- h1_ "404 Not Found"
- p_ (toHtml msg)
+ sendText $ "See: " <> rhref getRootHtmlR [("q", "404")]
+
+
+ postCaseR :: Route '[] Handler
+ postCaseR = post handle // "case" // "" /? acceptForm
+ where
+ handle = do
+ (res, view) <- postForm "addCase" addCaseForm
+
+ case res of
+ Nothing -> do
+ setStatus status400
+ sendHTML do
+ simpleForm_ view
+
+ Just ac -> do
+ _case <- addCase ac
+ redirect (rhref getCasesR [])
+
+ getCasesR :: Route '[] Handler
+ getCasesR = get handle // "case" // "" /? offerHTML
+ where
+ handle = do
+ setHeader hCacheControl "no-store"
- postCaseR :: Action ()
- postCaseR = do
- (res, view) <- postForm "addCase" addCaseForm
+ cases <- liftIO . readMVar . modelCases =<< getModelEnv
- case res of
- Nothing -> do
- setStatus status400
sendHTML do
- simpleForm_ view
-
- Just ac -> do
- _case <- addCase ac
- redirect "/case/"
-
-
- getCasesR :: Action ()
- getCasesR = do
- cases <- liftIO . readMVar . modelCases =<< getModelEnv
-
- sendHTML do
- h1_ "Cases"
-
- form_ [method_ "POST"] do
- view <- newForm "addCase" Nothing addCaseForm
- simpleForm_ view
- button_ [type_ "submit"] "Submit"
-
- table_ do
- tr_ do
- th_ "Id"
- th_ "Name"
- th_ "RecNo"
- th_ "Mode"
- th_ "Active"
-
- forM cases \Case{..} -> do
- tr_ do
- td_ $ toHtml $ tshow caseId
- td_ $ toHtml $ caseName
- td_ $ toHtml $ caseRecNo
- td_ $ toHtml $ tshow caseMode
- td_ $ toHtml $ tshow caseActive
+ h1_ "Cases"
+
+ form_ [method_ "POST"] do
+ view <- newForm "addCase" Nothing addCaseForm
+ simpleForm_ view
+ button_ [type_ "submit"] "Submit"
+
+ table_ do
+ tr_ do
+ th_ "Id"
+ th_ "Name"
+ th_ "RecNo"
+ th_ "Mode"
+ th_ "Active"
+
+ forM cases \Case{..} -> do
+ tr_ do
+ td_ $ toHtml $ tshow caseId
+ td_ $ toHtml $ caseName
+ td_ $ toHtml $ caseRecNo
+ td_ $ toHtml $ tshow caseMode
+ td_ $ toHtml $ tshow caseActive
-- Forms -------------------------------------------------------------------
diff --git a/test/Hikaru/DemoSpec.hs b/test/Hikaru/DemoSpec.hs
index 7294c40e5bc6832368e9641058ab2520f01293a1..431b189399b2f5d12bcce5583b35326e73971598 100644
--- a/test/Hikaru/DemoSpec.hs
+++ b/test/Hikaru/DemoSpec.hs
@@ -1,14 +1,14 @@
-{-|
-Module : Hikaru.DemoSpec
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-Smoke tests coverting a simple demo site.
--}
+-- |
+-- Module : Hikaru.DemoSpec
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- Smoke tests coverting a simple demo site.
+--
module Hikaru.DemoSpec
( spec
@@ -47,7 +47,7 @@ where
runDemo do
resp <- get "/404" []
assertStatus 404 resp
- assertBodyContains "404" resp
+ assertBody "See: /?q=404" resp
describe "GET /hello/<arg>" do
it "greets caller" do
@@ -58,6 +58,21 @@ where
assertHeader hCacheControl "no-store" resp
assertBody "Hello, Tester!" resp
+ it "greets hacker" do
+ runDemo do
+ resp <- get "/hello/Tester%2FHacker" []
+ assertStatus 200 resp
+ assertHeader hContentType "text/plain; charset=utf8" resp
+ assertHeader hCacheControl "no-store" resp
+ assertBody "Hello, Tester/Hacker!" resp
+
+ it "fails without a name" do
+ runDemo do
+ resp <- get "/hello/nobody" []
+ assertStatus 400 resp
+ assertHeader hContentType "text/plain; charset=utf8" resp
+ assertBody "I don't like you." resp
+
describe "POST /api/echo" do
it "echoes JSON payload" do
runDemo do
diff --git a/test/Hikaru/FormSpec.hs b/test/Hikaru/FormSpec.hs
index e4cd162b5e8c37dddd3972f678226defe54742e9..79d0bb9fe89a3feb314614e0be3c9429519d89df 100644
--- a/test/Hikaru/FormSpec.hs
+++ b/test/Hikaru/FormSpec.hs
@@ -1,12 +1,12 @@
-{-|
-Module : Hikaru.FormSpec
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
--}
+-- |
+-- Module : Hikaru.FormSpec
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
module Hikaru.FormSpec
( spec
diff --git a/test/Hikaru/Test.hs b/test/Hikaru/Test.hs
index ed6ceb4ee3381a00a5a504021d972df3664029f3..04560a29375acecda113847aa6ab4dadba57456b 100644
--- a/test/Hikaru/Test.hs
+++ b/test/Hikaru/Test.hs
@@ -1,14 +1,14 @@
-{-|
-Module : Hikaru.Test
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
-
-Common testing definitions.
--}
+-- |
+-- Module : Hikaru.Test
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
+-- Common testing definitions.
+--
module Hikaru.Test
( get
diff --git a/test/Spec.hs b/test/Spec.hs
index c5f149aed5bb95baed47333312c2fd74e95ecbb9..2a00874586afcaa61b7119d0cca36a98c31cbb82 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -1,12 +1,12 @@
-{-|
-Module : Spec
-Copyright : Jan Hamal Dvořák
-License : MIT
-
-Maintainer : mordae@anilinux.org
-Stability : unstable
-Portability : non-portable (ghc)
--}
+-- |
+-- Module : Spec
+-- Copyright : Jan Hamal Dvořák
+-- License : MIT
+--
+-- Maintainer : mordae@anilinux.org
+-- Stability : unstable
+-- Portability : non-portable (ghc)
+--
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}