working example json + store encoding

shai-hulud.cabal

@@ -31,9 +31,12 @@ library
   exposed-modules:   Lib
                    , ShaiHulud.App
   build-depends:     base >= 4.8 && < 5
+                   , aeson
+                   , bytestring
                    , http-types
                    , protolude
                    , wai
+                   , store
 
 executable shai-hulud-exe
   default-language:  Haskell2010

src/ShaiHulud/App.hs

@@ -1,16 +1,75 @@
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes        #-}
 
 module ShaiHulud.App
   ( app )
 where
 
-import Protolude
+import           Protolude
 
-import Network.Wai
-import Network.HTTP.Types
+import           Data.Aeson              (FromJSON)
+import qualified Data.Aeson              as JSON
+import           Data.ByteString.Builder (byteString, toLazyByteString)
+import qualified Data.ByteString.Lazy    as LZ
+import           Data.Store
+import           Network.HTTP.Types
+import           Network.Wai
+
+data Route = Route { _path    :: [Text]
+                   , _handler :: LZ.ByteString -> IO ByteString
+                   }
+
+data ShaiHuludApp = ShaiHuludApp { _routes :: [Route] }
+
+routeMatch :: Request -> Route -> Bool
+routeMatch request route = (pathInfo request == _path route)
+
+data InputFoo = InputFoo {_foo :: Text} deriving (Generic,FromJSON)
+data Foo = Foo Text deriving (Store,Generic)
+
+data InputBar = InputBar {_bar :: Text} deriving (Generic,FromJSON)
+data Bar = Bar Text deriving (Store,Generic)
+
+handleFoo :: InputFoo -> IO Foo
+handleFoo (InputFoo x) = return $ Foo x
+
+handleBar :: InputBar -> IO Bar
+handleBar (InputBar x) = return $ Bar x
+
+data DecodeException = DecodeException LZ.ByteString deriving (Show,Typeable)
+instance Exception DecodeException
+
+toEnc :: (FromJSON a, Store b) => (a -> IO b) -> LZ.ByteString -> IO ByteString
+toEnc f body = do
+  case JSON.decode body of
+    Nothing -> throwIO (DecodeException body)
+    Just x -> do
+      result <- f x
+      return $ encode result
+
+shaiApp :: ShaiHuludApp
+shaiApp = ShaiHuludApp
+  [ Route { _path = ["foo"], _handler = toEnc handleFoo }
+  , Route { _path = ["bar"], _handler = toEnc handleBar }
+  ]
+
+-- | makeApp is a function that provided an App custom representation
+-- for us it will be ShaiHuludApp returns a WAI Application
+-- This function is responsible to make the representation real.
+makeApp :: ShaiHuludApp -> Application
+makeApp sApp request respond =
+  case headMay $ filter (routeMatch request) (_routes sApp) of
+    Nothing -> respond $ responseLBS status404 [("Content-Type","text/plain")] ""
+    Just route -> do
+      body <- requestBody request
+      resp <-  (_handler route) (toLazyByteString (byteString body))
+      respond $ responseLBS status200 [("Content-Type","text/plain")] (toLazyByteString ( byteString resp ))
+
+-- test with
+-- curl -XPOST -d"{\"_foo\":\"bolo\"}" http://localhost:8080/foo
 
 app :: Application
-app _ respond = do
-  putText "I've done some IO here"
-  respond $ responseLBS status200 [("Content-Type","text/plain")] "Hello, Web!"
+app = makeApp shaiApp

stack.yaml

@@ -15,7 +15,7 @@
 # resolver:
 #  name: custom-snapshot
 #  location: "./custom-snapshot.yaml"
-resolver: nightly-2017-01-25
+resolver: nightly-2017-02-03
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.