hdo 0.3 → 0.4

raw patch · 3 files changed

+58/−21 lines, 3 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• hdo.cabal +1/−1
• src/Network/DO.hs +8/−3
• src/Network/REST/Conduit.hs +49/−17

@@ -1,5 +1,5 @@ Name: hdo-Version: 0.3+Version: 0.4 Cabal-Version: >= 1.18 Maintainer: Arnaud Bailly <arnaud.oqube@gmail.com> Author: Arnaud Bailly

@@ -1,4 +1,5 @@-{-# LANGUAGE ScopedTypeVariables, TypeOperators #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-} module Network.DO(   -- * Types   Command,@@ -14,7 +15,7 @@   listDomains, createDomain, deleteDomain,   listRecords, createRecord, deleteRecord,   -- * Utilities-  runDOEnv, runDO, getAuthFromEnv, outputResult,+  runDOEnv, runDO, runDODebug, getAuthFromEnv, outputResult,   generateName,   module Network.DO.Droplets.Utils) where @@ -112,7 +113,11 @@  -- | Run DO actions, passing a built authentication token. runDO :: Command IO a -> Maybe AuthToken -> IO a-runDO actions token =  runConduit $ pairEffectM (\ _ b -> return b) (mkDOClient $ Tool Nothing token False) actions+runDO actions token =  runConduit NoDebug $ pairEffectM (\ _ b -> return b) (mkDOClient $ Tool Nothing token False) actions++-- | Run DO actions, debugging requests, passing a built authentication token.+runDODebug :: Command IO a -> Maybe AuthToken -> IO a+runDODebug actions token =  runConduit Debug $ pairEffectM (\ _ b -> return b) (mkDOClient $ Tool Nothing token False) actions   getAuthFromEnv :: IO (Maybe AuthToken)

@@ -1,21 +1,48 @@+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Implementation of @REST@ interface based on <https://haskell-lang.org/library/http-client http-conduit> -- standard library module Network.REST.Conduit where -import           Control.Concurrent       (threadDelay)+import           Control.Concurrent         (threadDelay) import           Control.Monad.Trans.Free-import           Data.Aeson               (Value, decode, eitherDecode)-import           Data.CaseInsensitive     (mk)-import           Data.Functor             (void)-import           Data.Text.Encoding       (encodeUtf8)+import           Data.Aeson                 (ToJSON, Value, decode,+                                             eitherDecode, encode)+import           Data.ByteString.Lazy.Char8 (unpack)+import           Data.CaseInsensitive       (mk)+import           Data.Functor               (void)+import           Data.Text.Encoding         (encodeUtf8) import           Network.HTTP.Simple import           Network.REST.Commands import           Network.URI +data Debug where+  NoDebug   :: Debug+  Debug     :: Debug++data WithBody where+  Body :: forall a . (ToJSON a) => a -> WithBody++data RequestLog where+  RequestLog         :: Request                -> RequestLog+  RequestLogWithBody :: Request -> WithBody -> RequestLog++debugRequest :: Debug -> RequestLog -> IO ()+debugRequest NoDebug _                                 = pure ()+debugRequest Debug   (RequestLog req)                  = putStrLn $ "request: " ++ show req+debugRequest Debug   (RequestLogWithBody req (Body b)) = putStrLn $ "request: " ++ show req ++ ", body: " ++ unpack (encode b)++debugResponse :: (Show a) => Debug -> IO (Response a) -> IO (Response a)+debugResponse NoDebug act = act+debugResponse Debug   act = do+  response <- act+  putStrLn $ "response: " ++ show response+  pure response+ -- | An implementation of @REST@ functor based on http-client and @IO@-runConduit :: RESTT IO r -> IO r-runConduit r = do+runConduit :: Debug -> RESTT IO r -> IO r+runConduit debug r = do   mr <- runFreeT r   step mr     where@@ -27,36 +54,41 @@       step (Free (WaitFor delay message k))  = do         putStrLn message         threadDelay delay-        runConduit k+        runConduit debug k        step (Free (Get uri k)) = do         request <- parseRequest $ "GET " ++ asString uri-        response <- httpJSON request+        debugRequest debug (RequestLog request)+        response <- debugResponse debug $ httpJSON request         let value = getResponseBody response :: Value-        runConduit (k value)+        runConduit debug (k value)        step (Free (GetWith opts uri k)) = do         request <- parseRequest $ "GET " ++ asString uri-        response <- httpJSON $ options opts request+        debugRequest debug (RequestLog request)+        response <- debugResponse debug $ httpJSON $ options opts request         let value = getResponseBody response :: Value-        runConduit (k value)+        runConduit debug (k value)        step (Free (DeleteWith opts uri k)) = do         request <- parseRequest $ "DELETE " ++ asString uri+        debugRequest debug (RequestLog request)         void $ httpLBS $ options opts request-        runConduit k+        runConduit debug k        step (Free (Post uri val k)) = do         request <- parseRequest $ "POST " ++ asString uri-        response <- httpLbs $ setRequestBodyJSON val request+        debugRequest debug (RequestLogWithBody request (Body val))+        response <- debugResponse debug  $ httpLbs $ setRequestBodyJSON val request         let value = decode $ getResponseBody response-        runConduit (k value)+        runConduit debug (k value)        step (Free (PostWith opts uri val k)) = do         request <- parseRequest $ "POST " ++ asString uri-        response <- httpLbs $ options opts $ setRequestBodyJSON val request+        debugRequest debug (RequestLogWithBody request (Body val))+        response <- debugResponse debug $ httpLbs $ options opts $ setRequestBodyJSON val request         let value :: Either String Value = eitherDecode $ getResponseBody response-        runConduit (k value)+        runConduit debug (k value)   options :: Options -> Request -> Request