Add createOrder function

src/Lisa/Squeak.hs

@@ -2,6 +2,7 @@
 
 module Lisa.Squeak where
 
+import Control.Applicative ((<|>))
 import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON), Value, (.:), (.:?), (.=), object, withObject)
 import Data.Text (Text)
 import Data.Time.Calendar (Day)
@@ -159,3 +160,60 @@ login username password = fmap unLoginResult <$> replyToEither <$> responseBody
             [ "username" .= username
             , "password" .= password
             ]
+
+data SqueakError
+    = SqueakError
+        Text -- ^ Error code
+        Text -- ^ Human-readable message
+    | GQLErrors [GQLError]
+    deriving (Show)
+
+instance FromJSON SqueakError where
+    parseJSON = withObject "SqueakError" $ \v -> SqueakError
+        <$> v .: "errorCode"
+        <*> v .: "msg"
+
+newtype SqueakErrorOr a = SqueakErrorOr (Either SqueakError a)
+    deriving (Show)
+
+instance FromJSON a => FromJSON (SqueakErrorOr a) where
+    -- | Parse 'SqueakError' if @errorCode@ and @msg@ are present; otherwise, parse an 'a'.
+    parseJSON v = SqueakErrorOr
+        <$> ((Left <$> parseJSON v)
+        <|> (Right <$> parseJSON v))
+
+data CreateOrderResult = CreateOrderResult { unCreateOrderResult :: SqueakErrorOr Order }
+    deriving (Show)
+
+instance (FromJSON CreateOrderResult) where
+    parseJSON = withObject "CreateOrderResult" $ \v -> CreateOrderResult
+        <$> v .: "createOrder"
+
+data Order = Order
+    { orderId       :: Text
+    , orderTag      :: Text
+    , orderNumPages :: Int
+    }
+    deriving (Show)
+
+instance FromJSON Order where
+    parseJSON = withObject "Order" $ \v -> Order
+        <$> v .: "id"
+        <*> v .: "tag"
+        <*> v .: "numPages"
+
+joinErrors :: Either [GQLError] (SqueakErrorOr a) -> Either SqueakError a
+joinErrors (Left errors) = Left $ GQLErrors errors
+joinErrors (Right (SqueakErrorOr inner)) = inner
+
+createOrder :: Text -> [Text] -> Req (Either SqueakError Order)
+createOrder tag documents = joinErrors <$> fmap unCreateOrderResult <$> replyToEither <$> responseBody <$> req POST serverUrl (ReqBodyJson $ GQLQueryWithVars q vars) jsonResponse mempty
+    where q = "mutation CreateOrder($tag: String!, $documents: [DocumentId!]!) \
+              \ { createOrder(tag: $tag, documents: $documents) \
+              \ { ... on Error { errorCode msg } \
+              \   ... on Order { id tag numPages } \
+              \ } }"
+          vars = object
+            [ "tag" .= tag
+            , "documents" .= documents
+            ]