diff --git a/shai-hulud.cabal b/shai-hulud.cabal index 5cdf553..467be1e 100644 --- a/shai-hulud.cabal +++ b/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 diff --git a/src/ShaiHulud/App.hs b/src/ShaiHulud/App.hs index 87284f9..ee10237 100644 --- a/src/ShaiHulud/App.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index 8420c4f..3a06bba 100644 --- a/stack.yaml +++ b/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.