Redesigned Hikaru.Form and introduced some tests

Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>

demo/Main.hs

+{-|
+Module      :  Main
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+-}
+
+module Main ( main
+            )
+where
+  import BasePrelude
+
+  import Hikaru.Demo (makeDemo)
+
+
+  data Options
+    = Options
+      { optMainFunc    :: Options -> IO ()
+      , optConf        :: String
+      }
+
+
+  mainFunc :: Parser (Options -> IO ())
+  mainFunc = flag' mainVersion ( long "version"
+                                 <> short 'V'
+                                 <> help "Show version information"
+                                 <> hidden
+                               )
+             <|> pure mainWebsite
+
+
+  options :: Parser Options
+  options = Options <$> mainFunc
+                    <*> strOption ( long "config"
+                                    <> short 'C'
+                                    <> help "Configuration file to read"
+                                    <> value "byrocraft.cfg"
+                                  )
+
+
+  main :: IO ()
+  main = do
+    opts <- execParser $
+      info (helper *> options)
+           ( fullDesc
+             <> progDesc "Collaborative Administration Tool"
+             <> footer "Report bugs at <http://github.com/mordae/byrocraft/issues>."
+           )
+
+    optMainFunc opts opts
+
+
+  mainVersion :: Options -> IO ()
+  mainVersion _opts = do
+    prog <- getProgName
+    putStrLn $ prog <> " " <> packageVersion
+
+
+  mainWebsite :: Options -> IO ()
+  mainWebsite Options{optConf} = serve =<< load [ Required optConf ]
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

hikaru.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 789872e5159353725050ec2764d9951be0fbf0c39bb684307f281650bb6fd9a8
+-- hash: 29d0cf827300a88d2c302f25025d2f8d70bf6580c115003871c8397c80211d86
 
 name:           hikaru
 version:        0.1.0.0
@@ -47,7 +47,7 @@ library
       Paths_hikaru
   hs-source-dirs:
       lib
-  default-extensions: BlockArguments DataKinds DefaultSignatures FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+  default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
   ghc-options: -Wall -Wcompat
   build-depends:
       aeson >=1.4 && <1.5
@@ -70,3 +70,43 @@ library
     , wai >=3.2 && <3.3
     , wai-extra >=3.0 && <3.1
   default-language: Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Hikaru.Demo
+      Hikaru.DemoSpec
+      Hikaru.FormSpec
+      Hikaru.Test
+      Paths_hikaru
+  hs-source-dirs:
+      test
+  default-extensions: BlockArguments DataKinds DefaultSignatures DeriveGeneric FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
+  ghc-options: -Wall -Wcompat -threaded -rtsopts -with-rtsopts=-N
+  cpp-options: -DTEST
+  build-tool-depends:
+      hspec-discover:hspec-discover
+  build-depends:
+      aeson >=1.4 && <1.5
+    , base >=4.13 && <4.14
+    , base-prelude >=1.3 && <1.4
+    , binary >=0.8 && <0.9
+    , bytestring >=0.10 && <0.11
+    , case-insensitive >=1.2 && <1.3
+    , containers >=0.6 && <0.7
+    , cookie >=0.4 && <0.5
+    , cryptonite >=0.26 && <0.27
+    , hikaru
+    , hspec
+    , http-types >=0.12 && <0.13
+    , lucid >=2.9 && <2.10
+    , mtl >=2.2 && <2.3
+    , resourcet >=1.2 && <1.3
+    , string-conversions >=0.4 && <0.5
+    , text >=1.2 && <1.3
+    , text-icu >=0.7 && <0.8
+    , time >=1.9 && <1.10
+    , wai >=3.2 && <3.3
+    , wai-extra >=3.0 && <3.1
+  default-language: Haskell2010

lib/Hikaru/Action.hs

@@ -855,7 +855,7 @@ where
 
   -- |
   -- Default @Content-Type@ to @text/html; charset=utf8@
-  -- and set the response body to the provided byte string.
+  -- and set the response body to the rendering of provided HTML markup.
   --
   sendHTML :: (MonadAction m) => HtmlT m a -> m ()
   sendHTML html = do

lib/Hikaru/Localize.hs

@@ -16,32 +16,31 @@ First, you need to create a message catalog:
 data SampleMessages
   = MsgSuccess
   | MsgFailure
+  deriving (Show)
 
 -- Default HTML rendering of the messages.
 instance 'ToHtml' SampleMessages where
   'toHtmlRaw' = 'toHtml'
-  'toHtml' MsgSuccess = \"Success\"
-  'toHtml' MsgFailure = \"Failure\"
 
 -- Language-specific rendering of those messages.
-instance Localized SampleMessages where
-  -- Czech variants
-  localize \"cs\" MsgSuccess = 'Just' \"Úspěch\"
-  localize \"cs\" MsgFailure = 'Just' \"Selhání\"
+instance Localizable SampleMessages where
+  -- English variants
+  'localize' \"en\" MsgSuccess = 'Just' \"Success\"
+  'localize' \"en\" MsgFailure = 'Just' \"Failure\"
 
-  -- English is the default
-  localize \"en\" msg        = 'Just' ('toHtml' msg)
+  -- Czech variants
+  'localize' \"cs\" MsgSuccess = 'Just' \"Úspěch\"
+  'localize' \"cs\" MsgFailure = 'Just' \"Selhání\"
 
   -- Otherwise try the next locale
-  localize _locale _msg    = 'Nothing'
+  'localize' _locale _msg = 'Nothing'
 @
 
 Next, create a preferred language list for every action:
 
 @
 'Hikaru.Dispatch.dispatch' runAction $ do
-  'Hikaru.Dispatch.wrapActions' ('selectLanguages' \"lang\" \"lang\" >>)
-
+  'Hikaru.Dispatch.wrapAction' ('selectLanguages' \"lang\" \"lang\" >>) $ do
     'Hikaru.Dispatch.route' ...
 @
 
@@ -59,7 +58,8 @@ getSampleR flag = do
 
 module Hikaru.Localize
   ( Locale
-  , Localized(..)
+  , Localizable(..)
+  , lc
   , lc_
   , selectLanguages
   )
@@ -84,35 +84,65 @@ where
   -- |
   -- Any message that can be rendered localized.
   --
-  class (ToHtml a) => Localized a where
+  class (Show l) => Localizable l where
     -- |
     -- Try to localize the message using given locale.
     -- Return 'Nothing' if the locale is not supported.
     --
-    localize :: (Monad m) => Locale -> a -> Maybe (HtmlT m ())
-    localize _lc = const Nothing
+    localize :: Locale -> l -> Maybe Text
+    localize _lang _msg = Nothing
     {-# INLINE localize #-}
 
+    -- |
+    -- Same as 'localize', but for HTML.
+    -- Defaults to using the plain 'localize'.
+    --
+    localizeHtml :: (Monad m) => Locale -> l -> Maybe (HtmlT m ())
+    localizeHtml lang = fmap toHtml . localize lang
+    {-# INLINE localizeHtml #-}
+
 
   -- |
   -- Instance to make 'Text' usable for interoperability and
   -- gradual localization.
   --
-  instance Localized Text where
-    localize _lc = Just . toHtml
+  instance Localizable Text where
+    localize _lc = Just
+    {-# INLINE localize #-}
+
+
+  -- |
+  -- Instance to make 'Maybe' values simpler to render localized.
+  --
+  instance Localizable l => Localizable (Maybe l) where
+    localize lang (Just msg) = localize lang msg
+    localize _ Nothing       = Just ""
     {-# INLINE localize #-}
 
 
+  -- |
+  -- Localize given message to the language indicated by the
+  -- 'getLanguages' of the current action. Uses 'localize' internally.
+  --
+  lc :: (MonadAction m, Localizable l) => l -> m Text
+  lc msg = do
+    langs <- getLanguages
+
+    case mapMaybe (flip localize msg) langs of
+      []  -> return $ cs $ show msg
+      x:_ -> return x
+
+
   -- |
   -- Localize given message to the language indicated by the
   -- 'getLanguages' of the current action.
   --
-  lc_ :: (MonadAction m, Localized a) => a -> HtmlT m ()
+  lc_ :: (MonadAction m, Localizable l) => l -> HtmlT m ()
   lc_ msg = do
     langs <- getLanguages
 
-    case mapMaybe (flip localize msg) langs of
-      []  -> toHtml msg
+    case mapMaybe (flip localizeHtml msg) langs of
+      []  -> toHtml $ show msg
       x:_ -> x
 
 

lib/Hikaru/Types.hs

@@ -22,8 +22,8 @@ where
   import Data.ByteString (ByteString)
   import Data.String.Conversions
   import Data.Text (Text, pack, unpack)
-  import Network.HTTP.Types.Status
   import Network.HTTP.Types.Header
+  import Network.HTTP.Types.Status
   import Network.Wai
 
   import qualified Data.ByteString.Lazy
@@ -181,21 +181,24 @@ where
     {-# INLINE toParam #-}
 
   instance Param Text where
-    fromParam = Just . id
+    fromParam "" = Nothing
+    fromParam sp = Just sp
     {-# INLINE fromParam #-}
 
     toParam = id
     {-# INLINE toParam #-}
 
   instance Param Data.Text.Lazy.Text where
-    fromParam = Just . Data.Text.Lazy.fromStrict
+    fromParam "" = Nothing
+    fromParam sp = Just $ Data.Text.Lazy.fromStrict sp
     {-# INLINE fromParam #-}
 
     toParam = Data.Text.Lazy.toStrict
     {-# INLINE toParam #-}
 
   instance Param Data.ByteString.ByteString where
-    fromParam = Just . Data.Text.Encoding.encodeUtf8
+    fromParam "" = Nothing
+    fromParam sp = Just $ Data.Text.Encoding.encodeUtf8 sp
     {-# INLINE fromParam #-}
 
     toParam = Data.Text.Encoding.decodeUtf8With
@@ -203,8 +206,9 @@ where
     {-# INLINE toParam #-}
 
   instance Param Data.ByteString.Lazy.ByteString where
-    fromParam = Just . Data.ByteString.Lazy.fromStrict
-                     . Data.Text.Encoding.encodeUtf8
+    fromParam "" = Nothing
+    fromParam sp = Just $ Data.ByteString.Lazy.fromStrict
+                        $ Data.Text.Encoding.encodeUtf8 sp
     {-# INLINE fromParam #-}
 
     toParam = Data.Text.Encoding.decodeUtf8With

package.yaml

@@ -26,6 +26,7 @@ default-extensions:
   - BlockArguments
   - DataKinds
   - DefaultSignatures
+  - DeriveGeneric
   - FlexibleInstances
   - GADTs
   - GeneralizedNewtypeDeriving
@@ -78,4 +79,17 @@ library:
     - Hikaru.Route
     - Hikaru.Types
 
+tests:
+  spec:
+    main: Spec.hs
+    source-dirs: test
+    ghc-options: -threaded -rtsopts -with-rtsopts=-N
+    cpp-options: -DTEST
+
+    dependencies:
+      - hikaru
+      - hspec
+
+    build-tools: hspec-discover
+
 # EOF

test/Hikaru/Demo.hs

+{-|
+Module      :  Hikaru.Demo
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+-}
+
+module Hikaru.Demo
+  ( makeDemo
+  )
+where
+  import BasePrelude hiding (for_, Option, Control)
+
+  import Control.Monad.Reader
+  import Data.Aeson ()
+  import Data.Text (Text)
+  import Hikaru
+  import Lucid
+  import Network.HTTP.Types.Header
+  import Network.HTTP.Types.Status
+  import Network.Wai
+
+
+  -- 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
+      , modelCases     :: MVar [Case]
+      }
+
+
+  makeModelEnv :: Word -> IO ModelEnv
+  makeModelEnv n = ModelEnv <$> newMVar n <*> newMVar []
+
+
+  countVisitor :: (MonadModel m) => m Word
+  countVisitor = do
+    counter <- modelCounter <$> getModelEnv
+    liftIO do
+      modifyMVar_ counter (return . succ)
+      readMVar counter
+
+
+  addCase :: (MonadModel m) => AddCase -> m Case
+  addCase AddCase{..} = do
+    nextId  <- liftIO . readMVar . modelCounter =<< getModelEnv
+
+    let case' = Case { caseId     = nextId
+                     , caseName   = acName
+                     , caseRecNo  = fromMaybe acName acRecNo
+                     , caseMode   = acMode
+                     , caseActive = acActive
+                     }
+
+    cases <- modelCases <$> getModelEnv
+
+    liftIO do
+      modifyMVar_ cases (return . (<> [case']))
+      return case'
+
+
+  -- Dispatching -------------------------------------------------------------
+
+
+  makeDemo :: IO Application
+  makeDemo = do
+    model <- makeModelEnv 0
+    return $ makeApplication model
+
+
+  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 404 error handler.
+      handler NotFound handleNotFound
+
+      -- 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
+        -- Present a simple greeting page.
+        route $ getHelloR <$ get <* seg "hello" <*> arg
+                          <* offerText
+
+        -- Present an echoing JSON API.
+        route $ postEchoR <$ post <* seg "api" <* seg "echo"
+                          <* offerJSON <* acceptJSON
+
+        -- Case handling.
+        route $ postCaseR <$ post <* seg "case" <* seg "" <* acceptForm
+        route $ getCasesR <$ get  <* seg "case" <* seg "" <* offerJSON
+
+
+  -- 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!"
+
+
+  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)
+
+
+  postCaseR :: Action ()
+  postCaseR = do
+    (res, view) <- postForm "addCase" addCaseForm
+
+    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"
+
+        for cases \Case{..} -> do
+          tr_ do
+            td_ $ toHtml $ show caseId
+            td_ $ toHtml $ caseName
+            td_ $ toHtml $ caseRecNo
+            td_ $ toHtml $ show caseMode
+            td_ $ toHtml $ show caseActive
+
+
+  -- Forms -------------------------------------------------------------------
+
+
+  simpleForm_ :: (MonadAction m, Localizable l) => View l -> HtmlT m ()
+  simpleForm_ View{..} = do
+    forM_ viewControls \ctrl@Control{..} -> do
+      viewControl_ ctrl
+      forM_ ctrlNotes \Note{..} -> do
+        p_ do
+          lc_ noteMessage
+
+    forM_ viewElements \Element{..} -> do
+      div_ do
+        div_ do
+          case elemControls of
+            Control{..}:_ -> label_ [for_ ctrlName] $ lc_ elemLabel
+            _otherwise    -> label_ $ lc_ elemLabel
+
+        div_ do
+          forM_ elemControls \ctrl@Control{..} -> do
+            viewControl_ ctrl
+
+          forM_ elemControls \Control{..} -> do
+            forM_ ctrlNotes \Note{..} -> do
+              p_ do
+                lc_ noteMessage
+
+
+  viewControl_ :: (Localizable l, MonadAction m) => Control l -> HtmlT m ()
+  viewControl_ Control{..} = do
+    case ctrlField of
+      InputField{..} -> do
+        ph <- lc fieldPlacehold
+        input_ [ type_ fieldType
+               , name_ ctrlName
+               , placeholder_ ph
+               , value_ fieldValue
+               ]
+
+      SelectField{..} -> do
+        select_ [name_ ctrlName] do
+          mapM_ viewOption_ fieldOptions
+
+
+  viewOption_ :: (MonadAction m, Localizable l) => Option l -> HtmlT m ()
+  viewOption_ Option{..} = do
+    case optionSelected of
+      True -> do
+        option_ [selected_ "selected", value_ optionValue] do
+          lc_ optionLabel
+
+      False -> do
+        option_ [value_ optionValue] do
+          lc_ optionLabel
+
+
+  data Case
+    = Case
+      { caseId         :: Word
+      , caseName       :: Text
+      , caseRecNo      :: Text
+      , caseMode       :: AccessMode
+      , caseActive     :: Bool
+      }
+    deriving (Show, Generic)
+
+
+  data AddCase
+    = AddCase
+      { acName         :: Text
+      , acRecNo        :: Maybe Text
+      , acMode         :: AccessMode
+      , acActive       :: Bool
+      }
+
+  data AccessMode
+    = ModePublic
+    | ModePrivate
+    deriving (Show, Eq)
+
+  instance Param AccessMode where
+    toParam ModePublic  = "public"
+    toParam ModePrivate = "private"
+
+    fromParam "public"  = Just ModePublic
+    fromParam "private" = Just ModePrivate
+    fromParam _else     = Nothing
+
+
+  data RenderHint
+    = RenderCollapsed
+    | RenderExpanded
+    deriving (Eq, Show)
+
+
+  data Messages
+    = MsgCaseName
+    | MsgCaseMode
+    | MsgCaseEnabled
+    | MsgForm FormMessage
+    deriving (Show)
+
+  instance Localizable Messages where
+    localize "en" MsgCaseName    = Just "Name"
+    localize "en" MsgCaseMode    = Just "Mode"
+    localize "en" MsgCaseEnabled = Just "Enabled"
+
+    localize lang (MsgForm msg)  = localize lang msg
+    localize _lang _msg          = Nothing
+
+  instance FromFormMessage Messages where
+    fromFormMessage = MsgForm
+
+
+  addCaseForm :: (MonadAction m) => Form Messages m AddCase
+  addCaseForm = do
+    (\(x1, x2) x3 x4 -> AddCase x1 x2 x3 x4)
+      <$> element MsgCaseName do
+            (,)
+              <$> input "name" acName do
+                    return ()
+
+              <*> input "recno" acRecNo do
+                    return ()
+
+      <*> element MsgCaseMode do
+            select "mode" acMode do
+              return ()
+
+      <*> element MsgCaseEnabled do
+            select "active" acActive do
+              hint RenderExpanded
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

test/Hikaru/DemoSpec.hs

+{-|
+Module      :  Hikaru.DemoSpec
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+
+Smoke tests coverting a simple demo site.
+-}
+
+module Hikaru.DemoSpec
+  ( spec
+  )
+where
+  import BasePrelude
+
+  import Hikaru.Demo
+  import Hikaru.Test
+
+
+  spec :: Spec
+  spec = do
+    describe "GET /" do
+      context "by default" do
+        it "responds with 200 and text/html" do
+          runDemo do
+            resp <- get "/" []
+            assertStatus 200 resp
+            assertHeader hContentType "text/html; charset=utf8" resp
+            assertBodyContains "<h1>Welcome" resp
+            assertBodyContains " 1. " resp
+
+      context "when asked for text/plain" do
+        it "responds with 200 and text/plain" do
+          runDemo do
+            resp <- get "/" [(hAccept, "text/plain")]
+            assertStatus 200 resp
+            assertHeader hContentType "text/plain; charset=utf8" resp
+            assertBodyContains "Welcome" resp
+            assertBodyContains " 2. " resp
+
+    describe "GET /404" do
+      it "responds with 404" do
+        runDemo do
+          resp <- get "/404" []
+          assertStatus 404 resp
+          assertBodyContains "404" resp
+
+    describe "GET /hello/<arg>" do
+      it "greets caller" do
+        runDemo do
+          resp <- get "/hello/Tester" []
+          assertStatus 200 resp
+          assertHeader hContentType "text/plain; charset=utf8" resp
+          assertHeader hCacheControl "no-store" resp
+          assertBody "Hello, Tester!" resp
+
+    describe "POST /api/echo" do
+      it "echoes JSON payload" do
+        runDemo do
+          resp <- post "/api/echo" [(hContentType, "application/json")] "[1, 2]"
+          assertStatus 200 resp
+          assertBody "[1,2]" resp
+
+
+  demo :: Application
+  demo = unsafePerformIO makeDemo
+
+
+  runDemo :: Session a -> IO a
+  runDemo s = runSession s demo
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

test/Hikaru/FormSpec.hs

+{-|
+Module      :  Hikaru.FormSpec
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+-}
+
+module Hikaru.FormSpec
+  ( spec
+  )
+where
+  import BasePrelude
+
+  import Hikaru ()
+  import Hikaru.Test
+
+
+  -- Spec --------------------------------------------------------------------
+
+
+  spec :: Spec
+  spec = do
+    describe "form" do
+      it "has tests written" do
+        False
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

test/Hikaru/Test.hs

+{-|
+Module      :  Hikaru.Test
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+
+Common testing definitions.
+-}
+
+module Hikaru.Test
+  ( get
+  , post
+
+  , module Network.HTTP.Types
+  , module Network.Wai
+  , module Network.Wai.Internal
+  , module Network.Wai.Test
+  , module Test.Hspec
+  )
+where
+  import BasePrelude
+
+  import qualified Data.ByteString.Lazy as Lazy
+
+  import Data.ByteString (ByteString)
+  import Network.HTTP.Types
+  import Network.Wai
+  import Network.Wai.Internal
+  import Network.Wai.Test
+  import Test.Hspec
+
+
+  get :: ByteString -> RequestHeaders -> Session SResponse
+  get path headers =
+    let req = setPath defaultRequest path
+     in request $ req { requestMethod = methodGet
+                      , requestHeaders = headers
+                      }
+
+
+  post :: ByteString -> RequestHeaders -> ByteString -> Session SResponse
+  post path headers body = srequest sreq
+    where
+      req = setPath defaultRequest path
+      sreq = SRequest { simpleRequestBody = Lazy.fromStrict body
+                      , simpleRequest     = req { requestMethod  = methodPost
+                                                , requestHeaders = headers
+                                                }
+                      }
+
+
+-- vim:set ft=haskell sw=2 ts=2 et:

test/Spec.hs

+{-|
+Module      :  Spec
+Copyright   :  Jan Hamal Dvořák
+License     :  AGPL-3
+
+Maintainer  :  mordae@anilinux.org
+Stability   :  unstable
+Portability :  non-portable (ghc)
+-}
+
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+
+
+-- vim:set ft=haskell sw=2 ts=2 et: