gdritter repos shelob / 144f726
Starting to work on shelob-client too Getty Ritter 7 years ago
5 changed file(s) with 140 addition(s) and 49 deletion(s). Collapse all Expand all
+1
-0
cabal.project less more
1 packages: shelob/shelob.cabal, shelob-client/shelob-client.cabal
+0
-16
shelob/src/Network/Shelob/Types.hs less more
1 {-# LANGUAGE FlexibleInstances #-}
21 module Network.Shelob.Types where
32
43 import qualified Control.Exception as Ex
5049 instance Ex.Exception HTTPError where
5150 toException = undefined
5251 fromException = undefined
53
54 class HTTPResult t where
55 fromResponse :: Either HTTPError Response -> t
56
57 instance HTTPResult r => HTTPResult (Either HTTPError r) where
58 fromResponse (Left err) = Left err
59 fromResponse (Right v) = Right (fromResponse (Right v))
60
61 instance HTTPResult r => HTTPResult (Maybe r) where
62 fromResponse (Left _) = Nothing
63 fromResponse (Right v) = Just (fromResponse (Right v))
64
65 instance HTTPResult Response where
66 fromResponse (Left err) = Ex.throw err
67 fromResponse (Right v) = v
+6
-33
shelob/src/Network/Shelob.hs less more
22
33 module Network.Shelob where
44
5 import Control.Monad.IO.Class (MonadIO(..))
65 import qualified Data.ByteString as BS
76 import qualified Data.ByteString.Char8 as BS8
87 import qualified Network.Socket as Sock
1312 import Network.Shelob.Response
1413 import Network.Shelob.Types
1514
16 newtype ConnM a = ConnM { runConnM :: Connection -> IO a }
17
18 instance Functor ConnM where
19 fmap f (ConnM g) = ConnM (\ c -> fmap f (g c))
20
21 instance Applicative ConnM where
22 pure x = ConnM (\ _ -> return x)
23 ConnM f <*> ConnM x = ConnM $ \ c -> do
24 f' <- f c
25 x' <- x c
26 return (f' x')
27
28 instance Monad ConnM where
29 ConnM x >>= f = ConnM $ \ c -> do
30 x' <- x c
31 runConnM (f x') c
32
33 instance MonadIO ConnM where
34 liftIO m = ConnM (\ _ -> m)
35
36 connect :: Connection -> ConnM a -> IO a
37 connect conn m = do
38 rs <- runConnM m conn
39 connClose conn
40 return rs
41
4215 userAgent :: Header
4316 userAgent = Header "User-Agent" "haskell/vriska"
4417
4821 , userAgent
4922 ]
5023
51 head :: BS.ByteString -> [Header] -> ConnM (Either HTTPError Response)
52 head p hs = ConnM (\ c -> makeRequest c (Request MHead p (hs' ++ hs) ""))
24 head :: BS.ByteString -> [Header] -> Request
25 head p hs = Request MHead p (hs' ++ hs) ""
5326 where hs' = [ Header "Content-Length" "0"
5427 , userAgent
5528 ]
5629
57 get :: BS.ByteString -> [Header] -> ConnM (Either HTTPError Response)
58 get p hs = ConnM (\ c -> makeRequest c (Request MGet p (hs' ++ hs) ""))
30 get :: BS.ByteString -> [Header] -> Request
31 get p hs = Request MGet p (hs' ++ hs) ""
5932 where hs' = [ Header "Content-Length" "0"
6033 , userAgent
6134 ]
6235
63 post :: BS.ByteString -> [Header] -> BS.ByteString -> ConnM (Either HTTPError Response)
64 post p hs body = ConnM (\ c -> makeRequest c (Request MPost p (hs' ++ hs) body))
36 post :: BS.ByteString -> [Header] -> BS.ByteString -> Request
37 post p hs body = Request MPost p (hs' ++ hs) body
6538 where hs' = [ Header "Content-Length" (BS8.pack (show (BS.length body)))
6639 , userAgent
6740 ]
+25
-0
shelob-client/shelob-client.cabal less more
1 name: shelob-client
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 license-file: LICENSE
7 author: Getty Ritter <gettyritter@gmail.com>
8 maintainer: Getty Ritter <gettyritter@gmail.com>
9 copyright: ©2017 Getty Ritter
10 -- category:
11 build-type: Simple
12 cabal-version: >= 1.14
13
14 library
15 exposed-modules: Network.Shelob.Client
16 hs-source-dirs: src
17 ghc-options: -Wall
18 build-depends: base >=4.7 && <4.10
19 , shelob
20 , text
21 , bytestring
22 , aeson
23 default-language: Haskell2010
24 default-extensions: OverloadedStrings,
25 ScopedTypeVariables
+108
-0
shelob-client/src/Network/Shelob/Client.hs less more
1 {-# LANGUAGE FlexibleInstances #-}
2 module Network.Shelob.Client where
3
4 import Control.Monad.IO.Class (MonadIO(..))
5 import qualified Control.Exception as Ex
6 import qualified Data.Aeson as Aeson
7 import qualified Data.ByteString as BS
8 import qualified Data.ByteString.Char8 as BS8
9 import qualified Data.Text as T
10 import qualified Data.Text.Encoding as T
11
12 import Network.Shelob
13 import Network.Shelob.Types
14
15
16 newtype ConnM a = ConnM { runConnM :: Connection -> IO a }
17
18 instance Functor ConnM where
19 fmap f (ConnM g) = ConnM (\ c -> fmap f (g c))
20
21 instance Applicative ConnM where
22 pure x = ConnM (\ _ -> return x)
23 ConnM f <*> ConnM x = ConnM $ \ c -> do
24 f' <- f c
25 x' <- x c
26 return (f' x')
27
28 instance Monad ConnM where
29 ConnM x >>= f = ConnM $ \ c -> do
30 x' <- x c
31 runConnM (f x') c
32
33 instance MonadIO ConnM where
34 liftIO m = ConnM (\ _ -> m)
35
36 -- * HTTPPayload
37 -- | Types that implement
38 class HTTPPayload t where
39 toPayload :: t -> BS.ByteString
40
41 instance HTTPPayload BS.ByteString where
42 toPayload = id
43
44 instance HTTPPayload T.Text where
45 toPayload = T.encodeUtf8
46
47 newtype JSONPayload t = JSONPayload { fromJSONPayload :: t }
48
49 instance Aeson.FromJSON t => Aeson.FromJSON (JSONPayload t) where
50 parseJSON x = fmap JSONPayload (Aeson.parseJSON x)
51
52 -- * HTTPResult
53 class HTTPResult t where
54 fromResponse :: Either HTTPError Response -> t
55
56 instance HTTPResult r => HTTPResult (Either HTTPError r) where
57 fromResponse (Left err) = Left err
58 fromResponse (Right v) = Right (fromResponse (Right v))
59
60 instance HTTPResult r => HTTPResult (Maybe r) where
61 fromResponse (Left _) = Nothing
62 fromResponse (Right v) = Just (fromResponse (Right v))
63
64 onSuccess :: (Response -> a) -> Either HTTPError Response -> a
65 onSuccess _ (Left err) = Ex.throw err
66 onSuccess f (Right v) = f v
67
68 instance HTTPResult Response where
69 fromResponse = onSuccess id
70
71 instance HTTPResult BS.ByteString where
72 fromResponse = onSuccess (go . responseBody)
73 where go Nothing = Ex.throw HTTPError
74 go (Just x) = x
75
76 instance Aeson.FromJSON t => HTTPResult (JSONPayload t) where
77 fromResponse = onSuccess (go . responseBody)
78 where go Nothing = Ex.throw HTTPError
79 go (Just x)
80 | Just rs <- Aeson.decode x = JSONPayload x
81 | otherwise = Ex.throw HTTPError
82
83 withConn :: Connection -> ConnM a -> IO a
84 withConn conn m = do
85 rs <- runConnM m conn
86 connClose conn
87 return rs
88
89 doRequest :: HTTPResult r => Request -> ConnM r
90 doRequest req = ConnM (\ c -> fromResponse `fmap` makeRequest c req)
91
92 head :: HTTPResult r => BS.ByteString -> [Header] -> ConnM r
93 head p hs = doRequest (Request MHead p (hs' ++ hs) "")
94 where hs' = [ Header "Content-Length" "0"
95 , userAgent
96 ]
97
98 get :: HTTPResult r => BS.ByteString -> [Header] -> ConnM r
99 get p hs = doRequest (Request MGet p (hs' ++ hs) "")
100 where hs' = [ Header "Content-Length" "0"
101 , userAgent
102 ]
103
104 post :: HTTPResult r => BS.ByteString -> [Header] -> BS.ByteString -> ConnM r
105 post p hs body = doRequest (Request MPost p (hs' ++ hs) body)
106 where hs' = [ Header "Content-Length" (BS8.pack (show (BS.length body)))
107 , userAgent
108 ]