able to start a web server and run the mock API handlers

contributes to #41, #32

Hash2Pub.cabal

@@ -46,7 +46,7 @@ category:            Network
 extra-source-files:  CHANGELOG.md
 
 common deps
-  build-depends:       base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text
+  build-depends:       base ^>=4.12.0.0, containers ^>=0.6.0.1, bytestring, utf8-string ^>=1.0.1.1, network ^>=2.8.0.1, time ^>=1.8.0.2, cmdargs ^>= 0.10, cryptonite ^>= 0.25, memory, async, stm, asn1-encoding, asn1-types, asn1-parse, publicsuffix, network-byte-order, safe, iproute, mtl, random, servant, servant-server, servant-client, warp, text, http-api-data
   ghc-options:         -Wall
 
 

src/Hash2Pub/FediChordTypes.hs

@@ -607,7 +607,7 @@ data FediChordConf = FediChordConf
     -- ^ list of potential bootstrapping nodes
     , confBootstrapSamplingInterval :: Int
     -- ^ pause between sampling the own ID through bootstrap nodes, in seconds
-    , confMaxLookupCacheAge :: POSIXTime
+    , confMaxLookupCacheAge         :: POSIXTime
     -- ^ maximum age of lookup cache entries in seconds
     }
     deriving (Show, Eq)

src/Hash2Pub/PostService.hs

@@ -1,17 +1,86 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeOperators         #-}
 
 module Hash2Pub.PostService where
 
-import Servant
-import qualified Data.Text as Txt
+import qualified Data.ByteString.Lazy.UTF8 as BSU
+import           Data.Maybe                (fromMaybe)
+import qualified Data.Text                 as Txt
 
-type ServiceAPI = "relay" :> "inbox" :> PostCreated '[PlainText] Txt.Text
-             -- ^ delivery endpoint of new posts to relay 
-             :<|> "relay" :> "subscribers" :> Post '[PlainText] Txt.Text
-             -- ^ endpoint for delivering the subscription and outstanding queue 
-             :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
-             :<|> "tags" :> Capture "hashtag" Txt.Text :> PostCreated '[PlainText] Txt.Text
-             :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
-             :<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
+import qualified Network.Wai.Handler.Warp  as Warp
+import           Servant
+import           Web.HttpApiData           (showTextData)
+
+type PostServiceAPI = "relay" :> "inbox" :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
+                 -- ^ delivery endpoint of newly published posts of the relay's instance
+                 :<|> "relay" :> "subscribers" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
+                 -- ^ endpoint for delivering the subscriptions and outstanding queue
+                 :<|> "post" :> Capture "postid" Txt.Text :> Get '[PlainText] Txt.Text
+                 -- ^ fetch endpoint for posts, full post ID is http://$domain/post/$postid
+                 :<|> "posts" :> ReqBody '[PlainText] Txt.Text :> Post '[PlainText] Txt.Text
+                 -- ^ endpoint for fetching multiple posts at once
+                 :<|> "tags" :> Capture "hashtag" Txt.Text :> ReqBody '[PlainText] Txt.Text :> PostCreated '[PlainText] Txt.Text
+                 -- ^ delivery endpoint for posts of $tag at subscribing instance
+                 :<|> "tags" :> Capture "hashtag" Txt.Text :> "subscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Integer
+                 -- ^ endpoint for subscribing the instance specified in
+                 -- the Origin header to $hashtag.
+                 -- Returns subscription lease time in seconds.
+                 :<|> "tags" :> Capture "hashtag" Txt.Text :> "unsubscribe" :> Header "Origin" Txt.Text :> Get '[PlainText] Txt.Text
+                 -- ^ endpoint for unsubscribing the instance specified in
+                 -- the Origin header to $hashtag
+
+
+postServer :: Server PostServiceAPI
+postServer = relayInbox
+        :<|> subscriptionDelivery
+        :<|> postFetch
+        :<|> postMultiFetch
+        :<|> tagDelivery
+        :<|> tagSubscribe
+        :<|> tagUnsubscribe
+
+
+-- | needed for guiding type inference
+exposedPostServiceAPI :: Proxy PostServiceAPI
+exposedPostServiceAPI = Proxy
+
+-- | return a WAI application
+postServiceApplication :: Application
+postServiceApplication = serve exposedPostServiceAPI postServer
+
+servicePort = 8081
+
+runService :: IO ()
+runService = Warp.run servicePort postServiceApplication
+
+relayInbox :: Txt.Text -> Handler Txt.Text
+relayInbox post = pure $ "Here be InboxDragons with " <> post
+
+subscriptionDelivery :: Txt.Text -> Handler Txt.Text
+subscriptionDelivery subList = pure $ "Here be Subscription List dragons: " <> subList
+
+postFetch :: Txt.Text -> Handler Txt.Text
+postFetch postID = pure $ "Here be a post with dragon ID " <> postID
+
+postMultiFetch :: Txt.Text -> Handler Txt.Text
+postMultiFetch postIDs = pure $ "Here be multiple post dragons: "
+                      <> (Txt.unwords . Txt.lines $ postIDs)
+
+tagDelivery :: Txt.Text -> Txt.Text -> Handler Txt.Text
+tagDelivery hashtag posts = pure $ "Here be #" <> hashtag <> " dragons with " <> posts
+
+tagSubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Integer
+tagSubscribe hashtag origin = pure 42
+
+tagUnsubscribe :: Txt.Text -> Maybe Txt.Text -> Handler Txt.Text
+tagUnsubscribe hashtag origin = pure $ "Here be a dragon unsubscription from " <> fromMaybe "Nothing" origin <> " to " <> hashtag
+
+
+-- | define how to convert al showable types to PlainText
+-- No idea what I'm doing with these overlappable instances though ¯\_(ツ)_/¯
+-- TODO: figure out how this overlapping stuff actually works https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#instance-overlap
+instance {-# OVERLAPPABLE #-} Show a => MimeRender PlainText a where
+    mimeRender _ = BSU.fromString . show