Add bild --test

This argument will run the tests for an output after building. It's active in
'ci' so running that will ensure tests are passing. This way testing a
namespace and building a namespace are as close together as possible, so
presumably it will be that much easier to write good tests.

2 files changed, 51 insertions, 7 deletions

diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs
index f41c683..ce3f5da 100644
--- a/Biz/Que/Host.hs
+++ b/Biz/Que/Host.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -- | Interprocess communication
@@ -14,10 +15,13 @@
 -- : out que-server
 --
 -- : dep async
+-- : dep docopt
 -- : dep envy
 -- : dep protolude
 -- : dep scotty
 -- : dep stm
+-- : dep tasty
+-- : dep tasty-hunit
 -- : dep unagi-chan
 -- : dep unordered-containers
 module Biz.Que.Host
@@ -26,6 +30,9 @@ module Biz.Que.Host
 where
 
 import Alpha hiding (gets, modify, poll)
+import qualified Biz.Cli as Cli
+import Biz.Test ((@=?))
+import qualified Biz.Test as Test
 import qualified Control.Concurrent.Go as Go
 import qualified Control.Concurrent.STM as STM
 import qualified Control.Exception as Exception
@@ -49,7 +56,10 @@ import qualified Prelude
 {-# ANN module ("HLint: ignore Reduce duplication" :: Prelude.String) #-}
 
 main :: IO ()
-main = Exception.bracket startup shutdown <| uncurry Warp.run
+main = Cli.main <| Cli.Plan help move test
+
+move :: Cli.Arguments -> IO ()
+move _ = Exception.bracket startup shutdown <| uncurry Warp.run
   where
     startup =
       Envy.decodeWithDefaults Envy.defConfig >>= \c -> do
@@ -64,6 +74,19 @@ main = Exception.bracket startup shutdown <| uncurry Warp.run
     shutdown :: a -> IO a
     shutdown = pure <. identity
 
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+que-server
+
+Usage:
+  que-server
+  que-server test
+|]
+
+test :: Test.Tree
+test = Test.group "Biz.Que.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)]
+
 newtype App a = App
   { runApp :: ReaderT (STM.TVar AppState) IO a
   }
diff --git a/Biz/Que/Site.hs b/Biz/Que/Site.hs
index 99486a4..c4a6e0d 100644
--- a/Biz/Que/Site.hs
+++ b/Biz/Que/Site.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
@@ -8,16 +9,22 @@
 -- : out que-website
 --
 -- : dep async
+-- : dep docopt
 -- : dep config-ini
 -- : dep process
 -- : dep protolude
 -- : dep req
+-- : dep tasty
+-- : dep tasty-hunit
 module Biz.Que.Site
   ( main,
   )
 where
 
 import Alpha
+import qualified Biz.Cli as Cli
+import Biz.Test ((@=?))
+import qualified Biz.Test as Test
 import qualified Control.Concurrent.Async as Async
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Ini.Config as Config
@@ -32,12 +39,11 @@ import System.FilePath ((</>))
 import qualified System.Process as Process
 
 main :: IO ()
-main = do
-  (src, ns) <-
-    Environment.getArgs >>= \case
-      [src] -> return (src, "_") -- default to _ ns which is special
-      [src, ns] -> return (src, Text.pack ns)
-      _ -> Exit.die "usage: que-website <srcdir> [namespace]"
+main = Cli.main <| Cli.Plan help move test
+
+move :: Cli.Arguments -> IO ()
+move args = do
+  let (Just src, Just ns) = (getArg "src", Text.pack </ getArg "ns")
   mKey <- getKey ns
   putText <| "serving " <> Text.pack src <> " at " <> ns
   run mKey ns
@@ -49,6 +55,21 @@ main = do
         apidocs = src </> "Apidocs.md",
         tutorial = src </> "Tutorial.md"
       }
+  where
+    getArg = Cli.getArg args <. Cli.argument
+
+help :: Cli.Docopt
+help =
+  [Cli.docopt|
+que-website
+
+Usage:
+  que-website <src> <ns>
+  que-website test
+|]
+
+test :: Test.Tree
+test = Test.group "Biz.Que.Site" [Test.unit "id" <| 1 @=? (1 :: Integer)]
 
 getKey :: Namespace -> IO (Maybe Key)
 getKey ns = do