Commits

dp wiz committed 7ddcd5d

Add REST application environment and transformer layers traversal example for Post.get

  • Participants
  • Parent commits 11e7b0f

Comments (0)

Files changed (3)

+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module Api where
+
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.Trans (MonadIO)
+
+-- * App-specific things
+
+data Env = Env { envSomething :: () }
+
+setupEnv :: IO Env
+setupEnv = Env <$> pure ()
+
+-- * Generic things
+
+newtype ApiEnv a = ApiEnv { unApiEnv :: ReaderT Env IO a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadIO
+           , MonadReader Env
+           )
+
+runApiEnv :: Env -> ApiEnv a -> IO a
+runApiEnv env = flip runReaderT env . unApiEnv
+
+--env :: (Env -> a) -> ApiEnv a
+--env = lift . asks

File src/Api/Post.hs

 
 import Control.Monad.Reader
 
+import Api
+
 type Title = String
 
-resource :: Resource IO (ReaderT Title IO) Title () Void
+resource :: Resource ApiEnv (ReaderT Title ApiEnv) Title () Void
 resource = mkResourceReader
     { R.name   = "post"
     , R.schema = withListing () $ named [("title", singleBy id)]
 instance FromJSON Post
 instance JSONSchema Post where schema = gSchema
 
-get :: Handler (ReaderT Title IO)
-get = mkIdHandler (jsonO . someO) $ \_ title -> liftIO $ readPostFromDb title
+get :: Handler (ReaderT Title ApiEnv)
+get = mkIdHandler (jsonO . someO) getter
 
-readPostFromDb :: Title -> IO Post
-readPostFromDb title = do
-    print title
+--getter :: () -> Title -> (ReaderT Title ApiEnv) Post
+getter _ title = lift (evenGetter title)
+
+evenGetter :: Title -> (ReaderT Title ApiEnv) Post
+evenGetter title = lift $ do
+    something <- asks envSomething
+    liftIO $ print (something, title)
     return $ Post title "some content"
 
-list :: ListHandler IO
+list :: ListHandler ApiEnv
 list = mkListing (jsonO . someO) $ \range -> lift $ readPosts (count range) (offset range)
 
-readPosts :: Int -> Int -> IO [Post]
+readPosts :: Int -> Int -> ApiEnv [Post]
 readPosts a b = do
-    print (a, b)
+    liftIO $ print (a, b)
     return [ Post "some-title" "some content"
            , Post "other-title" "other content"
            , Post "more-title" "more content"
 import Rest.Driver.Wai
 import Network.Wai.Handler.Warp (run)
 
+import Api
 import qualified Api.Post as Post
 
-blog :: Router IO IO
+blog :: Router ApiEnv ApiEnv
 blog = root -/ post
     where
         post = route Post.resource
 
-api :: Api IO
+api :: Api ApiEnv
 api = [(mkVersion 1 0 0, Some1 blog)]
 
 main :: IO ()
 main = do
+    env <- setupEnv
     putStrLn "Take a look: http://localhost:3000/1.0/post"
-    run 3000 $ apiToApplication id api
+    run 3000 $ apiToApplication (runApiEnv env) api