Browse Source

working example json + store encoding

master
parent
commit
c695fa78f2
Signed by: yogsototh GPG Key ID: 7B19A4C650D59646
  1. 3
      shai-hulud.cabal
  2. 71
      src/ShaiHulud/App.hs
  3. 2
      stack.yaml

3
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

71
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

2
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.

Loading…
Cancel
Save