├── stack.yaml ├── stack-lts-14.7.yaml ├── stack-lts-9.21.yaml ├── stack-lts-11.22.yaml ├── stack-lts-12.26.yaml ├── stack-lts-13.19.yaml ├── Setup.hs ├── test-io ├── Spec.hs └── Network │ └── API │ └── Builder │ └── Examples │ └── StackOverflowSpec.hs ├── test ├── Spec.hs └── Network │ └── API │ └── Builder │ ├── RoutesSpec.hs │ ├── QuerySpec.hs │ ├── ErrorSpec.hs │ └── SendSpec.hs ├── .gitignore ├── src └── Network │ └── API │ ├── Builder.hs │ └── Builder │ ├── Query.hs │ ├── Send │ └── Multipart.hs │ ├── Builder.hs │ ├── Error.hs │ ├── Examples │ └── StackOverflow.hs │ ├── Routes.hs │ ├── Receive.hs │ ├── Send.hs │ └── API.hs ├── LICENSE ├── README.md ├── .circleci └── config.yml └── api-builder.cabal /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.15 2 | -------------------------------------------------------------------------------- /stack-lts-14.7.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.7 2 | -------------------------------------------------------------------------------- /stack-lts-9.21.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-9.21 2 | -------------------------------------------------------------------------------- /stack-lts-11.22.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-11.22 2 | -------------------------------------------------------------------------------- /stack-lts-12.26.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.26 2 | -------------------------------------------------------------------------------- /stack-lts-13.19.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.19 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test-io/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | */.DS_Store 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | dist/ 5 | .stack-work/ 6 | stack*.yaml.lock 7 | -------------------------------------------------------------------------------- /src/Network/API/Builder.hs: -------------------------------------------------------------------------------- 1 | -- | Entirely re-exports. 2 | module Network.API.Builder 3 | ( module Network.API.Builder.API 4 | , module Network.API.Builder.Builder 5 | , module Network.API.Builder.Error 6 | , module Network.API.Builder.Query 7 | , module Network.API.Builder.Receive 8 | , module Network.API.Builder.Routes 9 | , module Network.API.Builder.Send ) where 10 | 11 | import Network.API.Builder.API 12 | import Network.API.Builder.Builder 13 | import Network.API.Builder.Error 14 | import Network.API.Builder.Query 15 | import Network.API.Builder.Receive 16 | import Network.API.Builder.Routes 17 | import Network.API.Builder.Send 18 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Query.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Query where 2 | 3 | import Data.Text (Text) 4 | import qualified Data.Text as Text 5 | 6 | class ToQuery a where 7 | toQuery :: Text -> a -> [(Text, Text)] 8 | 9 | instance ToQuery Integer where 10 | toQuery k v = [(k, Text.pack $ show v)] 11 | 12 | instance ToQuery Bool where 13 | toQuery k True = [(k, "true")] 14 | toQuery k False = [(k, "false")] 15 | 16 | instance ToQuery Int where 17 | toQuery k v = [(k, Text.pack $ show v)] 18 | 19 | instance ToQuery Text where 20 | toQuery k v = [(k, v)] 21 | 22 | instance ToQuery a => ToQuery (Maybe a) where 23 | toQuery k (Just a) = toQuery k a 24 | toQuery _ Nothing = [] 25 | 26 | instance ToQuery a => ToQuery [a] where 27 | toQuery _ [] = [] 28 | toQuery k xs = [(k, Text.intercalate "," $ map snd $ concatMap (toQuery k) xs)] 29 | -------------------------------------------------------------------------------- /test/Network/API/Builder/RoutesSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.RoutesSpec where 2 | 3 | import Network.API.Builder.Routes 4 | 5 | import Test.Hspec 6 | 7 | main :: IO () 8 | main = hspec spec 9 | 10 | spec :: Spec 11 | spec = do 12 | describe "routeURL" $ do 13 | it "should be able to create a basic url" $ do 14 | routeURL "" (Route [ "api", "index" ] [ ] "GET") 15 | `shouldBe` "/api/index" 16 | routeURL "" (Route [ "api", "index.json" ] [ ] "GET") 17 | `shouldBe` "/api/index.json" 18 | routeURL "" (Route [ ] [ "test" =. False ] "GET") 19 | `shouldBe` "?test=false" 20 | routeURL "" (Route [ "about.json" ] [ "test" =. True ] "GET") 21 | `shouldBe` "/about.json?test=true" 22 | routeURL "" (Route [ "about.json" ] [ "test" =. True ] "GET") 23 | `shouldBe` "/about.json?test=true" 24 | 25 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Send/Multipart.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Send.Multipart 2 | ( sendMultipart 3 | , Multipart(..) ) where 4 | 5 | import Network.API.Builder.Builder 6 | import Network.API.Builder.Routes 7 | import Network.API.Builder.Send 8 | 9 | import Control.Monad 10 | import Control.Monad.IO.Class 11 | import Network.HTTP.Client.MultipartFormData 12 | import Network.HTTP.Client (Request) 13 | 14 | -- | A type for multipart forms, which uses 'Part's from 'Network.HTTP.Client.MultipartFormData'. 15 | -- Construct it and send it with 'sendMultipart' (not 'send'). 16 | data Multipart = Multipart [Part] 17 | deriving (Show) 18 | 19 | -- | Send a 'Multipart' request. This can't use the normal 'send' mechanism since 20 | -- it has to do IO to construct its request. 21 | sendMultipart :: MonadIO m => Builder -> Route -> Multipart -> m (Maybe Request) 22 | sendMultipart b r (Multipart ps) = do 23 | case send b r () of 24 | Nothing -> return Nothing 25 | Just req -> liftM Just $ formDataBody ps req 26 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Builder.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Builder 2 | ( Builder(..) 3 | , basicBuilder ) where 4 | 5 | import Network.API.Builder.Routes 6 | 7 | import Data.Text (Text) 8 | import Network.HTTP.Client (Request) 9 | import qualified Data.Text as T 10 | 11 | -- | Builder type for the API. Keeps track of the API's name and base URL, and how 12 | -- to modify Routes and Requests before they're run. 13 | data Builder = Builder { _name :: Text 14 | , _baseURL :: Text 15 | , _customizeRoute :: Route -> Route 16 | , _customizeRequest :: Request -> Request } 17 | 18 | instance Show Builder where 19 | show b = "Builder { name = " ++ T.unpack (_name b) ++ "}" 20 | 21 | -- | Makes a basic builder, i.e. one that simply has a name and base URL 22 | -- and doesn't fiddle with Routes / Requests. 23 | basicBuilder :: Text -- ^ name 24 | -> Text -- ^ base url 25 | -> Builder -- ^ a simple @Builder@ 26 | basicBuilder n b = Builder n b id id 27 | -------------------------------------------------------------------------------- /test/Network/API/Builder/QuerySpec.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.QuerySpec where 2 | 3 | import Network.API.Builder.Query 4 | 5 | import Test.Hspec 6 | import Test.Hspec.QuickCheck 7 | 8 | main :: IO () 9 | main = hspec spec 10 | 11 | spec :: Spec 12 | spec = 13 | describe "ToQuery" $ do 14 | 15 | it "can convert an Integer" $ do 16 | toQuery "integer" (5 :: Integer) `shouldBe` 17 | [("integer", "5")] 18 | 19 | it "can convert a Boolean" $ do 20 | toQuery "bool" False `shouldBe` [("bool", "false")] 21 | 22 | it "can convert a list of Ints" $ do 23 | toQuery "list" ([1,2,3,4,5] :: [Int]) `shouldBe` [("list", "1,2,3,4,5")] 24 | 25 | it "can convert Maybe values" $ do 26 | toQuery "maybe" (Just False) `shouldBe` [("maybe", "false")] 27 | toQuery "maybe" (Nothing :: Maybe Bool) `shouldBe` [] 28 | 29 | prop "toQuery x y == toQuery x (Just y)" $ \(y :: Int) -> 30 | toQuery "x" y == toQuery "x" (Just y) 31 | 32 | skip :: String -> Expectation -> Expectation 33 | skip _ _ = return () 34 | -------------------------------------------------------------------------------- /test/Network/API/Builder/ErrorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Network.API.Builder.ErrorSpec where 3 | 4 | import Data.Semigroup ((<>)) 5 | import Network.API.Builder.Error 6 | 7 | import Test.Hspec 8 | import Test.Hspec.QuickCheck 9 | import Test.QuickCheck 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | instance Arbitrary a => Arbitrary (APIError a) where 15 | arbitrary = oneof 16 | [ APIError <$> arbitrary 17 | , pure InvalidURLError 18 | , ParseError <$> arbitrary 19 | , pure EmptyError 20 | ] 21 | 22 | spec :: Spec 23 | spec = 24 | describe "APIError" $ do 25 | describe "Eq" $ do 26 | it "should check for equality properly" $ do 27 | HTTPError undefined == (HTTPError undefined :: APIError ()) 28 | `shouldBe` False 29 | APIError () `shouldBe` APIError () 30 | InvalidURLError `shouldBe` (InvalidURLError :: APIError ()) 31 | 32 | prop "ParseError s == ParseError s" $ \s -> 33 | ParseError s == (ParseError s :: APIError ()) 34 | 35 | prop "APIError x == APIError x" $ \(x :: String) -> 36 | APIError x == APIError x 37 | 38 | describe "Semigroup" $ do 39 | prop "(x <> y) <> z == x <> (y <> z)" $ \(x :: APIError ()) y z -> 40 | (x <> y) <> z == x <> (y <> z) 41 | -------------------------------------------------------------------------------- /test-io/Network/API/Builder/Examples/StackOverflowSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Examples.StackOverflowSpec where 2 | 3 | import Network.API.Builder.Examples.StackOverflow 4 | 5 | import Control.Monad 6 | import Data.List (nub) 7 | import Test.Hspec 8 | import qualified Data.Set as Set 9 | import qualified Data.Text as Text 10 | 11 | main :: IO () 12 | main = hspec spec 13 | 14 | spec :: Spec 15 | spec = 16 | describe "getAnswers" $ do 17 | 18 | it "can get answers" $ 19 | getAnswers >>= \case 20 | Left _ -> expectationFailure "getAnswers failed" 21 | Right (Questions qs) -> do 22 | nub qs `shouldMatchList` qs 23 | forM_ qs $ \q -> do 24 | tags q `shouldSatisfy` isNubbed 25 | title q `shouldSatisfy` (not . Text.null) 26 | 27 | it "can get answers via https" $ 28 | getAnswersSSL >>= \case 29 | Left _ -> expectationFailure "getAnswers failed" 30 | Right (Questions qs) -> do 31 | nub qs `shouldMatchList` qs 32 | forM_ qs $ \q -> do 33 | tags q `shouldSatisfy` isNubbed 34 | title q `shouldSatisfy` (not . Text.null) 35 | 36 | isNubbed :: Ord a => [a] -> Bool 37 | isNubbed = f Set.empty 38 | where 39 | f _ [] = True 40 | f s (x:xs) = not (Set.member x s) && f (Set.insert x s) xs 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Fraser Murray 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Fraser Murray nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Error.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Error 2 | ( APIError(..) ) where 3 | 4 | import Data.Semigroup 5 | import Network.HTTP.Client (HttpException) 6 | import Prelude 7 | 8 | -- | Error type for the @API@, where @a@ is the type that should be returned when 9 | -- something goes wrong on the other end - i.e. any error that isn't directly related 10 | -- to this library. 11 | data APIError a = APIError a -- ^ A type that represents any error that happens on the API end. 12 | -- Define your own custom type with a @FromJSON@ instance if you 13 | -- want to handle them, or you can use @()@ if you just want to 14 | -- ignore them all. 15 | | HTTPError HttpException -- ^ Something went wrong when we tried to do a HTTP operation. 16 | | InvalidURLError -- ^ You're trying to create an invalid URL somewhere - check your 17 | -- @Builder@'s base URL and your @Route@s. 18 | | ParseError String -- ^ Failed when parsing the response, and it wasn't an error on their end. 19 | | EmptyError -- ^ Empty error to serve as a zero element for Monoid. 20 | deriving Show 21 | 22 | instance Eq a => Eq (APIError a) where 23 | (APIError a) == (APIError b) = a == b 24 | InvalidURLError == InvalidURLError = True 25 | (ParseError a) == (ParseError b) = a == b 26 | EmptyError == EmptyError = True 27 | _ == _ = False 28 | 29 | instance Semigroup (APIError a) where 30 | EmptyError <> x = x 31 | x <> _ = x 32 | 33 | instance Monoid (APIError a) where 34 | mempty = EmptyError 35 | mappend = (<>) 36 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Examples/StackOverflow.hs: -------------------------------------------------------------------------------- 1 | -- | Defines a basic example of API use - check the readme for more detail 2 | -- or check the tutorial at 3 | module Network.API.Builder.Examples.StackOverflow where 4 | 5 | import Network.API.Builder 6 | import Control.Applicative ((<$>), (<*>)) 7 | import Data.Aeson 8 | import Data.Monoid (mempty) 9 | import Data.Text (Text) 10 | 11 | data Question = Question { title :: Text 12 | , isAnswered :: Bool 13 | , score :: Int 14 | , tags :: [Text] } 15 | deriving (Show, Eq) 16 | 17 | newtype Questions = Questions [Question] 18 | deriving (Show, Eq) 19 | 20 | instance FromJSON Question where 21 | parseJSON (Object o) = 22 | Question <$> o .: "title" 23 | <*> o .: "is_answered" 24 | <*> o .: "score" 25 | <*> o .: "tags" 26 | parseJSON _ = mempty 27 | 28 | instance FromJSON Questions where 29 | parseJSON (Object o) = Questions <$> o .: "items" 30 | parseJSON _ = mempty 31 | 32 | instance Receivable Questions where 33 | receive = useFromJSON 34 | 35 | stackOverflow :: Builder 36 | stackOverflow = basicBuilder "StackOverflow API" "http://api.stackexchange.com" 37 | 38 | stackOverflowSSL :: Builder 39 | stackOverflowSSL = basicBuilder "StackOverflow API" "https://api.stackexchange.com" 40 | 41 | answersRoute :: Route 42 | answersRoute = Route { urlPieces = [ "2.2", "questions" ] 43 | , urlParams = [ "order" =. ("desc" :: Text) 44 | , "sort" =. ("activity" :: Text) 45 | , "site" =. ("stackoverflow" :: Text) ] 46 | , httpMethod = "GET" } 47 | 48 | getAnswers :: IO (Either (APIError ()) Questions) 49 | getAnswers = execAPI stackOverflow () $ runRoute answersRoute 50 | 51 | getAnswersSSL :: IO (Either (APIError ()) Questions) 52 | getAnswersSSL = execAPI stackOverflowSSL () $ runRoute answersRoute 53 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Routes.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Routes 2 | ( Route(..) 3 | , URLPiece 4 | , URLParam 5 | , (=.) 6 | , routeURL ) where 7 | 8 | import Control.Arrow ((***)) 9 | import Data.Monoid ((<>)) 10 | import Data.Text (Text) 11 | import qualified Data.Text as T 12 | import qualified Network.HTTP.Base as HTTP (urlEncodeVars) 13 | import qualified Network.HTTP.Types.Method as HTTP 14 | 15 | import Network.API.Builder.Query 16 | 17 | -- | Alias for @Text@ to store the URL fragments for each @Route@. 18 | type URLPiece = Text 19 | 20 | -- | Alias to @(Text, Maybe Text)@ used to store each query that gets 21 | -- tacked onto the request. 22 | type URLParam = [(Text, Text)] 23 | 24 | -- | Convenience function for building @URLParam@s. Right-hand argument must 25 | -- have a @ToQuery@ instance so it can be converted to the appropriate 26 | -- representation in a query string. Query values do not need to be 27 | -- escaped. 28 | -- 29 | -- >>> "api_type" =. ("json" :: Text) 30 | -- ("api_type", Just "json") 31 | (=.) :: ToQuery a => Text -> a -> [(Text, Text)] 32 | k =. v = toQuery k v 33 | 34 | -- | Main type for routes in the API. Used to represent the URL minus the actual 35 | -- endpoint URL as well as the query string and the HTTP method used to communicate 36 | -- with the server. 37 | data Route = Route { urlPieces :: [URLPiece] 38 | , urlParams :: [URLParam] 39 | , httpMethod :: HTTP.Method } 40 | deriving (Show, Read, Eq) 41 | 42 | -- | Converts a Route to a URL. Drops any @Nothing@ values from the query, separates the 43 | -- fragments with "/" and tacks them onto the end of the base URL. 44 | routeURL :: Text -- ^ base URL for the @Route@ (you can usually get this from the @Builder@) 45 | -> Route -- ^ the @Route@ to process 46 | -> Text -- ^ the finalized URL as a @Text@ 47 | routeURL baseURL (Route fs ps _) = 48 | baseURL <> firstSep <> path <> querySep <> buildParams ps 49 | where 50 | firstSep = if null fs then T.empty else "/" 51 | path = T.intercalate "/" fs 52 | querySep = if null ps then T.empty else pathParamsSep fs 53 | 54 | 55 | pathParamsSep :: [URLPiece] -> Text 56 | pathParamsSep [] = "?" 57 | pathParamsSep xs = if T.isInfixOf "." (last xs) then "?" else "/?" 58 | 59 | buildParams :: [URLParam] -> Text 60 | buildParams = T.pack . HTTP.urlEncodeVars . concatMap (map (T.unpack *** T.unpack)) 61 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Receive.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Receive where 2 | 3 | import Network.API.Builder.Error 4 | 5 | import Control.Applicative 6 | import Data.Aeson 7 | import Data.ByteString.Lazy (ByteString) 8 | import Network.HTTP.Client 9 | import Prelude 10 | 11 | class Receivable r where 12 | receive :: ErrorReceivable e => Response ByteString -> Either (APIError e) r 13 | 14 | instance Receivable ByteString where 15 | receive = Right . responseBody 16 | 17 | instance Receivable (Response ByteString) where 18 | receive = Right 19 | 20 | instance Receivable Value where 21 | receive = useFromJSON 22 | 23 | instance (Receivable a, Receivable b) => Receivable (a, b) where 24 | receive x = (,) <$> receive x <*> receive x 25 | 26 | instance (Receivable a, Receivable b, Receivable c) => Receivable (a, b, c) where 27 | receive x = (,,) <$> receive x <*> receive x <*> receive x 28 | 29 | instance (Receivable a, Receivable b, Receivable c, Receivable d) => Receivable (a, b, c, d) where 30 | receive x = (,,,) <$> receive x <*> receive x <*> receive x <*> receive x 31 | 32 | instance (Receivable a, Receivable b, Receivable c, Receivable d, Receivable e) => Receivable (a, b, c, d, e) where 33 | receive x = (,,,,) <$> receive x <*> receive x <*> receive x <*> receive x <*> receive x 34 | 35 | useFromJSON :: (FromJSON a, ErrorReceivable e) => Response ByteString -> Either (APIError e) a 36 | useFromJSON resp = 37 | case eitherDecode $ responseBody resp of 38 | Left err -> 39 | case receiveError resp of 40 | Just x -> Left $ APIError x 41 | Nothing -> Left $ ParseError err 42 | Right x -> return x 43 | 44 | class ErrorReceivable e where 45 | receiveError :: Response ByteString -> Maybe e 46 | 47 | instance ErrorReceivable ByteString where 48 | receiveError = Just . responseBody 49 | 50 | instance ErrorReceivable () where 51 | receiveError _ = Nothing 52 | 53 | instance ErrorReceivable Value where 54 | receiveError = useErrorFromJSON 55 | 56 | useErrorFromJSON :: FromJSON a => Response ByteString -> Maybe a 57 | useErrorFromJSON resp = 58 | case eitherDecode (responseBody resp) of 59 | Right x -> Just x 60 | Left _ -> Nothing 61 | 62 | newtype JSONResponse a = JSONResponse { unwrapJSON :: a } 63 | deriving (Show, Read, Eq, Ord) 64 | 65 | instance FromJSON a => FromJSON (JSONResponse a) where 66 | parseJSON v = JSONResponse `fmap` parseJSON v 67 | 68 | instance FromJSON a => Receivable (JSONResponse a) where 69 | receive = useFromJSON 70 | 71 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # api-builder [![Build Status](https://travis-ci.org/intolerable/api-builder.svg?branch=master)](https://travis-ci.org/intolerable/api-builder) 2 | 3 | Simple library for building API wrappers in Haskell – define a `Builder`, add some types with `Receivable` instances, an error type, and some routes, and you can easily use any API from Haskell code. Based on a `EitherT StateT StateT` monad transformer stack. 4 | 5 | ## Stack Overflow example 6 | 7 | Define a type for a stack overflow question: 8 | 9 | ```haskell 10 | data Question = Question { title :: Text 11 | , isAnswered :: Bool 12 | , score :: Int 13 | , tags :: [Text] } 14 | deriving (Show, Eq) 15 | ``` 16 | 17 | And a wrapper since SO wraps its JSON responses: 18 | 19 | ```haskell 20 | newtype Questions = Questions [Question] 21 | deriving (Show, Eq) 22 | ``` 23 | 24 | Add `FromJSON` instances for both the types: 25 | 26 | ```haskell 27 | instance FromJSON Question where 28 | parseJSON (Object o) = 29 | Question <$> o .: "title" 30 | <*> o .: "is_answered" 31 | <*> o .: "score" 32 | <*> o .: "tags" 33 | parseJSON _ = mempty 34 | 35 | instance FromJSON Questions where 36 | parseJSON (Object o) = Questions <$> o .: "items" 37 | parseJSON _ = mempty 38 | ``` 39 | 40 | and a `Receivable` instance for `Questions` that just uses the `FromJSON` instance: 41 | 42 | ```haskell 43 | instance Receivable Questions where 44 | receive = useFromJSON 45 | ``` 46 | 47 | Define a `Builder` for the API endpoint: 48 | 49 | ```haskell 50 | stackOverflow :: Builder 51 | stackOverflow = basicBuilder "StackOverflow API" "http://api.stackexchange.com" 52 | ``` 53 | 54 | And the `Route` to use to get the data: 55 | 56 | ```haskell 57 | answersRoute :: Route 58 | answersRoute = Route { urlPieces = [ "2.2", "questions" ] 59 | , urlParams = [ "order" =. Just "desc" 60 | , "sort" =. Just "activity" 61 | , "site" =. Just "stackoverflow" ] 62 | , httpMethod = GET } 63 | ``` 64 | 65 | And a function to actually run the API: 66 | 67 | ```haskell 68 | getAnswers :: IO (Either (APIError ()) Questions) 69 | getAnswers = execAPI stackOverflow () $ runRoute answersRoute 70 | 71 | > getAnswers 72 | Right (Questions [Question {title = "Using parse API with codeigniter", isAnswered = True, score = 2, tags = ["php","codeigniter","parse.com","codeigniter-2","php-5.6"]},Question {title = "Object... 73 | ``` 74 | -------------------------------------------------------------------------------- /.circleci/config.yml: -------------------------------------------------------------------------------- 1 | version: 2.1 2 | jobs: 3 | build: &build 4 | docker: 5 | - image: fpco/stack-build:lts 6 | environment: 7 | STACK_YAML: stack.yaml 8 | steps: 9 | - checkout 10 | - run: 11 | name: Dump STACK_YAML 12 | command: cat $STACK_YAML > stack_yaml_contents 13 | - restore_cache: 14 | name: Restore cache 15 | key: api-builder-{{ checksum "api-builder.cabal" }}-{{ checksum "stack_yaml_contents" }} 16 | - run: 17 | name: Setup 18 | command: stack setup 19 | - run: 20 | name: Test 21 | command: stack test 22 | - restore_cache: 23 | name: Save cache 24 | key: api-builder-{{ checksum "api-builder.cabal" }}-{{ checksum "stack_yaml_contents" }} 25 | paths: 26 | - ~/.stack 27 | - ~/.stack-work 28 | build-nightly: 29 | <<: *build 30 | steps: 31 | - checkout 32 | - restore_cache: 33 | name: Restore cache 34 | key: api-builder-nightly-{{ checksum "api-builder.cabal" }}-{{ checksum "stack.yaml" }} 35 | - run: 36 | name: Set 37 | command: stack setup --resolver=nightly 38 | - run: 39 | name: Test 40 | command: stack test --resolver=nightly 41 | - restore_cache: 42 | name: Save cache 43 | key: api-builder-nightly-{{ checksum "api-builder.cabal" }}-{{ checksum "stack.yaml" }} 44 | paths: 45 | - ~/.stack 46 | - ~/.stack-work 47 | lts-9-21-build: 48 | <<: *build 49 | environment: 50 | STACK_YAML: stack-lts-9.21.yaml 51 | lts-11-22-build: 52 | <<: *build 53 | environment: 54 | STACK_YAML: stack-lts-11.22.yaml 55 | lts-12-26-build: 56 | <<: *build 57 | environment: 58 | STACK_YAML: stack-lts-12.26.yaml 59 | lts-13-19-build: 60 | <<: *build 61 | environment: 62 | STACK_YAML: stack-lts-13.19.yaml 63 | lts-14-7-build: 64 | <<: *build 65 | environment: 66 | STACK_YAML: stack-lts-14.7.yaml 67 | 68 | workflows: 69 | version: 2 70 | everything: 71 | jobs: 72 | - build 73 | - build-nightly 74 | - lts-9-21-build 75 | - lts-11-22-build 76 | - lts-12-26-build 77 | - lts-13-19-build 78 | - lts-14-7-build 79 | nightly: 80 | triggers: 81 | - schedule: 82 | cron: "0 18 * * *" 83 | filters: 84 | branches: 85 | only: 86 | - master 87 | jobs: 88 | - build-nightly 89 | -------------------------------------------------------------------------------- /api-builder.cabal: -------------------------------------------------------------------------------- 1 | name: api-builder 2 | version: 0.17.0.0 3 | synopsis: Library for easily building REST API wrappers in Haskell 4 | category: Network 5 | homepage: https://github.com/intolerable/api-builder 6 | author: Fraser Murray 7 | maintainer: fraser.m.murray@gmail.com 8 | copyright: (c) Fraser Murray 2014 9 | license: BSD3 10 | license-file: LICENSE 11 | build-type: Simple 12 | cabal-version: >= 1.10 13 | 14 | source-repository head 15 | type: git 16 | location: git://github.com/intolerable/api-builder.git 17 | 18 | library 19 | hs-source-dirs: src/ 20 | default-extensions: 21 | OverloadedStrings 22 | FlexibleInstances 23 | ghc-options: -Wall 24 | build-depends: 25 | HTTP >=4000, 26 | aeson >=0.9, 27 | base >=4.6, 28 | bifunctors >=4.0, 29 | bytestring >=0.10, 30 | http-client >=0.4.30, 31 | http-client-tls >=0.2, 32 | http-types >=0.8, 33 | text >=1.0, 34 | tls >=1.3, 35 | transformers >=0.4 36 | exposed-modules: 37 | Network.API.Builder 38 | Network.API.Builder.API 39 | Network.API.Builder.Builder 40 | Network.API.Builder.Error 41 | Network.API.Builder.Examples.StackOverflow 42 | Network.API.Builder.Query 43 | Network.API.Builder.Receive 44 | Network.API.Builder.Routes 45 | Network.API.Builder.Send 46 | Network.API.Builder.Send.Multipart 47 | other-modules: 48 | Paths_api_builder 49 | default-language: Haskell2010 50 | 51 | test-suite test 52 | type: exitcode-stdio-1.0 53 | main-is: Spec.hs 54 | hs-source-dirs: test/ 55 | default-extensions: OverloadedStrings FlexibleInstances ScopedTypeVariables 56 | ghc-options: -Wall 57 | build-depends: 58 | Cabal >=1.16.0, 59 | aeson, 60 | api-builder, 61 | base ==4.*, 62 | bytestring, 63 | hspec, 64 | http-client, 65 | QuickCheck, 66 | text, 67 | transformers 68 | other-modules: 69 | Network.API.Builder.ErrorSpec 70 | Network.API.Builder.QuerySpec 71 | Network.API.Builder.RoutesSpec 72 | Network.API.Builder.SendSpec 73 | Paths_api_builder 74 | default-language: Haskell2010 75 | 76 | test-suite test-io 77 | type: exitcode-stdio-1.0 78 | main-is: Spec.hs 79 | hs-source-dirs: test-io/ 80 | default-extensions: OverloadedStrings FlexibleInstances LambdaCase 81 | ghc-options: -Wall 82 | build-depends: 83 | Cabal >=1.16.0 84 | , aeson 85 | , api-builder 86 | , base ==4.* 87 | , bytestring 88 | , containers 89 | , hspec 90 | , text 91 | , transformers 92 | other-modules: 93 | Network.API.Builder.Examples.StackOverflowSpec 94 | Paths_api_builder 95 | default-language: Haskell2010 96 | -------------------------------------------------------------------------------- /src/Network/API/Builder/Send.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.Send where 2 | 3 | import Network.API.Builder.Builder 4 | import Network.API.Builder.Routes 5 | 6 | import Data.Aeson 7 | import Data.ByteString.Lazy (ByteString) 8 | import Network.HTTP.Client 9 | import qualified Data.ByteString.Char8 as ByteString 10 | import qualified Data.Text as Text 11 | 12 | -- | Class for types that can be sent with api-builder. 13 | -- Given a 'Builder', a 'Route', and an instance of 'Sendable', we should be able to construct a 'Request' for the API's server. If we can't, 'send' returns 'Nothing' and 'APIT' complains about being unable to send the given data. 14 | class Sendable s where 15 | send :: Builder -> Route -> s -> Maybe Request 16 | 17 | instance Sendable () where 18 | send builder r () = 19 | case httpMethod r of 20 | "POST" -> do 21 | req <- parseUrlThrow $ Text.unpack $ routeURL (_baseURL builder) (_customizeRoute builder r) 22 | return $ _customizeRequest builder $ 23 | req { requestHeaders = ("Content-Type", "application/x-www-form-urlencoded") : requestHeaders req 24 | , requestBody = RequestBodyBS (dropQuestion $ queryString req) 25 | , queryString = "" 26 | , method = httpMethod r } 27 | _ -> basicSend builder r 28 | where dropQuestion b = if ByteString.isPrefixOf "?" b then ByteString.drop 1 b else b 29 | 30 | basicSend :: Builder -> Route -> Maybe Request 31 | basicSend builder r = do 32 | req <- parseUrlThrow $ Text.unpack $ routeURL (_baseURL builder) (_customizeRoute builder r) 33 | return $ _customizeRequest builder $ req { method = httpMethod r } 34 | 35 | instance Sendable Value where 36 | send builder r value = 37 | case httpMethod r of 38 | "POST" -> do 39 | req <- parseUrlThrow $ Text.unpack $ routeURL (_baseURL builder) (_customizeRoute builder r) 40 | return $ _customizeRequest builder $ 41 | req { requestBody = RequestBodyLBS (encode value) 42 | , requestHeaders = ("Content-Type", "application/json") : requestHeaders req 43 | , method = httpMethod r } 44 | _ -> Nothing 45 | 46 | useToJSON :: ToJSON a => Builder -> Route -> a -> Maybe Request 47 | useToJSON b r v = send b r (toJSON v) 48 | 49 | instance Sendable ByteString where 50 | send builder r bs = 51 | case httpMethod r of 52 | "POST" -> do 53 | req <- basicSend builder r 54 | return $ req { requestBody = RequestBodyLBS bs } 55 | _ -> Nothing 56 | 57 | -- | By default, the '()' instance for 'Sendable' moves the query parameters of the 'Route' into the body of the POST request. Most APIs handle both, but some will complain if they aren't sent in the actual query. If you 'send' 'PostQuery' instead of '()', the query params won't move from the actual query string when constructing the request. 58 | data PostQuery = PostQuery 59 | deriving (Show) 60 | 61 | instance Sendable PostQuery where 62 | send builder r PostQuery = basicSend builder r 63 | -------------------------------------------------------------------------------- /test/Network/API/Builder/SendSpec.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.SendSpec where 2 | 3 | import Network.API.Builder.Builder 4 | import Network.API.Builder.Routes 5 | import Network.API.Builder.Send 6 | 7 | import Data.Aeson 8 | import Data.ByteString.Lazy (ByteString) 9 | import qualified Network.HTTP.Client as HTTP 10 | import Test.Hspec 11 | 12 | main :: IO () 13 | main = hspec spec 14 | 15 | spec :: Spec 16 | spec = do 17 | describe "Sendable" $ do 18 | 19 | describe "()" $ do 20 | it "should be able to construct a basic request" $ do 21 | case send exampleBuilder (Route ["api.json"] [] "GET") () of 22 | Just req -> do 23 | HTTP.secure req `shouldBe` True 24 | HTTP.host req `shouldBe` "example.com" 25 | HTTP.method req `shouldBe` "GET" 26 | HTTP.port req `shouldBe` 443 27 | HTTP.queryString req `shouldBe` "" 28 | HTTP.path req `shouldBe` "/api.json" 29 | Nothing -> expectationFailure "req construction failed" 30 | it "should be able to construct request with query params" $ do 31 | case send exampleBuilder (Route ["api.json"] ["a_query" =. True] "GET") () of 32 | Just req -> do 33 | HTTP.secure req `shouldBe` True 34 | HTTP.host req `shouldBe` "example.com" 35 | HTTP.method req `shouldBe` "GET" 36 | HTTP.port req `shouldBe` 443 37 | HTTP.queryString req `shouldBe` "?a_query=true" 38 | HTTP.path req `shouldBe` "/api.json" 39 | Nothing -> expectationFailure "req construction failed" 40 | it "should be able to construct a POST request" $ do 41 | case send exampleBuilder (Route ["api.json"] ["query" =. False] "POST") () of 42 | Just req -> do 43 | HTTP.secure req `shouldBe` True 44 | HTTP.host req `shouldBe` "example.com" 45 | HTTP.method req `shouldBe` "POST" 46 | HTTP.port req `shouldBe` 443 47 | HTTP.queryString req `shouldBe` "" 48 | HTTP.path req `shouldBe` "/api.json" 49 | case HTTP.requestBody req of 50 | HTTP.RequestBodyBS "query=false" -> return () 51 | _ -> expectationFailure "incorrect POST body" 52 | Nothing -> expectationFailure "req construction failed" 53 | 54 | describe "PostQuery" $ do 55 | it "should be able to construct a POST request with no body" $ do 56 | case send exampleBuilder (Route ["api.json"] ["query" =. False] "POST") PostQuery of 57 | Just req -> do 58 | HTTP.secure req `shouldBe` True 59 | HTTP.host req `shouldBe` "example.com" 60 | HTTP.method req `shouldBe` "POST" 61 | HTTP.port req `shouldBe` 443 62 | HTTP.queryString req `shouldBe` "?query=false" 63 | HTTP.path req `shouldBe` "/api.json" 64 | case HTTP.requestBody req of 65 | HTTP.RequestBodyLBS "" -> return () 66 | _ -> expectationFailure "incorrect POST body" 67 | Nothing -> expectationFailure "req construction failed" 68 | 69 | describe "Value" $ do 70 | it "should be able to construct a POST request with the correct JSON body" $ do 71 | case send exampleBuilder (Route ["api.json"] ["query" =. False] "POST") $ object ["hello" .= Null] of 72 | Just req -> do 73 | HTTP.secure req `shouldBe` True 74 | HTTP.host req `shouldBe` "example.com" 75 | HTTP.method req `shouldBe` "POST" 76 | HTTP.port req `shouldBe` 443 77 | HTTP.queryString req `shouldBe` "?query=false" 78 | HTTP.path req `shouldBe` "/api.json" 79 | case HTTP.requestBody req of 80 | HTTP.RequestBodyLBS "{\"hello\":null}" -> return () 81 | _ -> expectationFailure "incorrect POST body" 82 | Nothing -> expectationFailure "req construction failed" 83 | 84 | describe "ByteString" $ do 85 | it "should be able to construct a POST request with the correct ByteString body" $ do 86 | case send exampleBuilder (Route ["api.json"] ["query" =. False] "POST") ("hello world" :: ByteString) of 87 | Just req -> do 88 | HTTP.secure req `shouldBe` True 89 | HTTP.host req `shouldBe` "example.com" 90 | HTTP.method req `shouldBe` "POST" 91 | HTTP.port req `shouldBe` 443 92 | HTTP.queryString req `shouldBe` "?query=false" 93 | HTTP.path req `shouldBe` "/api.json" 94 | case HTTP.requestBody req of 95 | HTTP.RequestBodyLBS "hello world" -> return () 96 | _ -> expectationFailure "incorrect POST body" 97 | Nothing -> expectationFailure "req construction failed" 98 | 99 | exampleBuilder :: Builder 100 | exampleBuilder = basicBuilder "example" "https://example.com" 101 | -------------------------------------------------------------------------------- /src/Network/API/Builder/API.hs: -------------------------------------------------------------------------------- 1 | module Network.API.Builder.API ( 2 | -- * API 3 | API 4 | , APIT 5 | -- ** Running the API 6 | , execAPI 7 | , runAPI 8 | , runRoute 9 | , sendRoute 10 | , routeResponse 11 | , routeRequest 12 | -- ** Lifting 13 | , liftExcept 14 | , liftEither 15 | , liftManager 16 | , liftBuilder 17 | , liftState 18 | -- ** Changing the @Builder@ within the API 19 | , name 20 | , baseURL 21 | , customizeRoute 22 | , customizeRequest ) where 23 | 24 | import Network.API.Builder.Builder 25 | import Network.API.Builder.Error 26 | import Network.API.Builder.Receive 27 | import Network.API.Builder.Routes 28 | import Network.API.Builder.Send 29 | 30 | import Data.Bifunctor 31 | import Control.Exception 32 | import Control.Monad.IO.Class (MonadIO, liftIO) 33 | import Control.Monad.Trans.Class (lift) 34 | import Control.Monad.Trans.Except 35 | import Control.Monad.Trans.Reader 36 | import Control.Monad.Trans.State 37 | import Data.ByteString.Lazy (ByteString) 38 | import Data.Text (Text) 39 | import Network.HTTP.Client 40 | import Network.HTTP.Client.TLS 41 | 42 | -- | Main API type. @s@ is the API's internal state, @e@ is the API's custom error type, 43 | -- and @a@ is the result when the API runs. Based on the @APIT@ transformer. 44 | type API s e a = APIT s e IO a 45 | 46 | -- | Main API transformer type. @s@ is the API's internal state, @e@ is the API's custom error type, 47 | -- and @a@ is the result when the API runs. 48 | type APIT s e m a = ExceptT (APIError e) (ReaderT Manager (StateT Builder (StateT s m))) a 49 | 50 | -- | Lifts an action that works on an @API@ to an action that works on an @API@. 51 | -- This function is provided solely for future-proofing in the case that more transformers 52 | -- need to be stacked on top - it's implemented simply as @id@ for the moment. 53 | liftExcept :: Monad m => ExceptT (APIError e) (ReaderT Manager (StateT Builder (StateT s m))) a -> APIT s e m a 54 | liftExcept = id 55 | 56 | {-# DEPRECATED liftEither "Use liftExcept" #-} 57 | -- | Identical to 'liftExcept', provided for (almost) compatibility. 58 | liftEither :: Monad m => ExceptT (APIError e) (ReaderT Manager (StateT Builder (StateT s m))) a -> APIT s e m a 59 | liftEither = id 60 | 61 | -- | Lifts an action that works on a @Manager@ to one that works on an @API@. 62 | liftManager :: Monad m => ReaderT Manager (StateT Builder (StateT s m)) a -> APIT s e m a 63 | liftManager = lift 64 | 65 | -- | Lifts an action that operates on a @Builder@ to one that works on an @API@. Useful 66 | -- mainly for gaining access to a @Builder@ from inside an @API@. 67 | liftBuilder :: Monad m => StateT Builder (StateT s m) a -> APIT s e m a 68 | liftBuilder = lift . lift 69 | 70 | -- | Lifts an action on an @API@'s state type @s@ to one that works on the @API@. Good 71 | -- for messing with the state from inside the @API@. 72 | liftState :: Monad m => StateT s m a -> APIT s e m a 73 | liftState = lift . lift . lift 74 | 75 | -- | Runs an @API@ by executing its transformer stack and dumping it all into @IO@. Only returns the actual result. 76 | execAPI :: MonadIO m 77 | => Builder -- ^ initial @Builder@ for the @API@ 78 | -> s -- ^ initial state @s@ for the @API@ 79 | -> APIT s e m a -- ^ the actual @API@ to run 80 | -> m (Either (APIError e) a) -- ^ IO action that returns either an error or the result 81 | execAPI b s api = do 82 | m <- liftIO $ newManager tlsManagerSettings 83 | (res, _, _) <- runAPI b m s api 84 | return res 85 | 86 | -- | Runs an @API@ by executing its transformer stack and dumping it all into @IO@. 87 | -- | Returns the actual result as well as the final states of the @Builder@ and custom state @s@. 88 | runAPI :: MonadIO m 89 | => Builder -- ^ initial @Builder@ for the @API@ 90 | -> Manager -- ^ manager for working with conduit functions 91 | -> s -- ^ initial state @s@ for the @API@ 92 | -> APIT s e m a -- ^ the actual @API@ to run 93 | -> m (Either (APIError e) a, Builder, s) -- ^ IO action that returns either an error or the result, as well as the final states 94 | runAPI b m s api = do 95 | ((res, b'), s') <- runStateT (runStateT (runReaderT (runExceptT api) m) b) s 96 | return (res, b', s') 97 | 98 | -- | Runs a @Route@. Infers the type to convert to from the JSON with the @a@ in @API@, 99 | -- and infers the error type from @e@. 100 | runRoute :: (Receivable a, ErrorReceivable e, MonadIO m) => Route -> APIT s e m a 101 | runRoute = sendRoute () 102 | 103 | -- | Runs a @Route@, but only returns the response and does nothing towards 104 | -- decoding the response. 105 | routeResponse :: (MonadIO m, ErrorReceivable e) => Route -> APIT s e m (Response ByteString) 106 | routeResponse = sendRoute () 107 | 108 | eitherOr :: Maybe a -> b -> Either b a 109 | a `eitherOr` b = 110 | case a of 111 | Just x -> Right x 112 | Nothing -> Left b 113 | 114 | sendRoute :: (MonadIO m, Sendable t, ErrorReceivable e, Receivable r) => t -> Route -> APIT s e m r 115 | sendRoute s r = do 116 | builder <- liftBuilder get 117 | manager <- liftManager ask 118 | req <- ExceptT $ return $ send builder r s `eitherOr` InvalidURLError 119 | response <- liftIO $ try $ httpLbs req manager 120 | res <- ExceptT $ return $ first HTTPError response 121 | ExceptT $ return $ receive res 122 | 123 | -- | Try to construct a @Request@ from a @Route@ (with the help of the @Builder@). Returns @Nothing@ if 124 | -- the URL is invalid or there is another error with the @Route@. 125 | routeRequest :: Builder -> Route -> Maybe Request 126 | routeRequest b route = send b route () 127 | 128 | -- | Modify the @name@ of the @Builder@ from inside an API. Using this is probably not the best idea, 129 | -- it's nice if the @Builder@'s name is stable at least. 130 | name :: Monad m => Text -> APIT s e m () 131 | name t = liftBuilder $ modify (\b -> b { _name = t }) 132 | 133 | -- | Modify the @baseURL@ of the @Builder@ from inside an API. 134 | -- Can be useful for changing the API's endpoints for certain requests. 135 | baseURL :: Monad m => Text -> APIT s e m () 136 | baseURL t = liftBuilder $ modify (\b -> b { _baseURL = t }) 137 | 138 | -- | Modify every @Route@ before it runs. Useful for adding extra params to every query, 139 | -- for example. 140 | customizeRoute :: Monad m => (Route -> Route) -> APIT s e m () 141 | customizeRoute f = liftBuilder $ modify (\b -> b { _customizeRoute = f }) 142 | 143 | -- | Modify every @Request@ before the API fetches it. Useful for adding headers to every request, 144 | -- for example. 145 | customizeRequest :: Monad m => (Request -> Request) -> APIT s e m () 146 | customizeRequest f = liftBuilder $ modify (\b -> b { _customizeRequest = f }) 147 | --------------------------------------------------------------------------------