rfc 0.0.0.20 → 0.0.0.21

raw patch · 15 files changed

+182/−64 lines, 15 filesdep +freer-simpledep +natural-transformationdep +unliftiodep −asyncdep −exceptionsdep −lifted-basedep ~classy-preludedep ~hedisdep ~lifted-async

Dependencies added: freer-simple, natural-transformation, unliftio, unliftio-core

Dependencies removed: async, exceptions, lifted-base

Dependency ranges changed: classy-prelude, hedis, lifted-async, monad-control, servant, servant-blaze, servant-client, servant-docs, servant-server, servant-swagger, swagger2

Files

• rfc.cabal +19/−17
• src/RFC/Client/Coinhive.hs +3/−2
• src/RFC/Concurrent.hs +12/−5
• src/RFC/Data/ListMoveDirection.hs +22/−3
• src/RFC/Data/UUID.hs +9/−0
• src/RFC/Env.hs +17/−4
• src/RFC/HTTP/Client.hs +9/−9
• src/RFC/JSON.hs +2/−2
• src/RFC/Log.hs +5/−4
• src/RFC/Miso/String.hs +1/−0
• src/RFC/Prelude.hs +10/−3
• src/RFC/Redis.hs +5/−5
• src/RFC/Servant.hs +14/−7
• src/RFC/Servant/ApiDoc.hs +38/−1
• src/RFC/String.hs +16/−2

@@ -1,5 +1,5 @@ name:                rfc-version:             0.0.0.20+version:             0.0.0.21 synopsis:            Robert Fischer's Common library description:         An enhanced Prelude and various utilities for Aeson, Servant, PSQL, and Redis that Robert Fischer uses. homepage:            https://github.com/RobertFischer/rfc#README.md@@ -28,57 +28,59 @@   build-depends:       base >= 4.7 && < 5   default-language:    Haskell2010   default-extensions:  NoImplicitPrelude-  ghc-options:         -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-tabs+  ghc-options:         -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-tabs   if flag(Development)     ghc-options:       -Werror   build-depends:       base >= 4.7 && < 5-                     , servant-                     , classy-prelude >= 1.3 && < 1.4+                     , classy-prelude >= 1.4                      , uuid-types                      , containers                      , unordered-containers                      , string-conversions-                     , monad-control                      , resource-pool-                     , async                      , data-default-                     , servant-blaze+                     , servant-blaze >= 0.8                      , blaze-html                      , url                      , lens                      , http-types-                     , exceptions                      , http-api-data >= 0.3.7.1                      , time-units                      , aeson-diff                      , vector-                     , lifted-async                      , text                      , bifunctors-                     , lifted-base >= 0.2.3.11+                     , lifted-async >= 0.9.3.3+                     , unliftio >= 0.2.4.0+                     , unliftio-core >= 0.1.1.0+                     , monad-control >= 1.0.2.2+                     , freer-simple >= 1.0.1.1+                     , natural-transformation >= 0.4   if flag(Browser)     build-depends:     aeson                      , attoparsec                      , miso >= 0.12.0.0+                     , servant >= 0.12.1 && < 0.13   if !flag(Browser)-    build-depends:     servant-server+    build-depends:     servant-server >= 0.13+                     , servant >= 0.13+                     , servant-docs >= 0.11.2                      , wai >= 3.2.1.1                      , aeson >= 1.2.3.0                      , wai-extra                      , wai-cors                      , postgresql-simple >= 0.5.3.0-                     , hedis+                     , hedis >= 0.10.0                      , simple-logger-                     , servant-docs                      , temporary                      , http-client                      , http-client-tls                      , wreq >= 0.5.2.0-                     , servant-swagger-                     , swagger2-                     , binary+                     , servant-swagger >= 1.1.5+                     , swagger2 >= 2.2                      , markdown-                     , servant-client+                     , servant-client >= 0.13+                     , binary    exposed-modules:     RFC.Prelude                      , RFC.String

@@ -76,15 +76,16 @@   }  -- |Perform a verification of a token.-tokenVerify :: (MonadThrow m, MonadIO m, HasHttpManager m) => TokenVerifyRequest -> m TokenVerification+tokenVerify :: (MonadUnliftIO m, HasHttpManager m) => TokenVerifyRequest -> m TokenVerification tokenVerify req = do   manager <- getHttpManager   let env = ClientEnv {..}   result <- liftIO $ runClientM (tokenVerifyM req) env   case result of-    Left err       -> throw err+    Left err       -> throwIO err     Right response -> return response   where     baseUrl = apiUrlBase+    cookieJar = Nothing  #endif

@@ -4,23 +4,30 @@  module RFC.Concurrent   ( module RFC.Concurrent+  , module Control.Monad.IO.Unlift+  , module UnliftIO.Concurrent   , module Control.Concurrent.Async.Lifted+  , module Control.Monad.Trans.Control   ) where -import           Control.Concurrent.Async.Lifted-import           RFC.Prelude                     hiding (mapConcurrently)+import           Control.Concurrent.Async.Lifted hiding (mapConcurrently,+                                                  mapConcurrently_)+import           Control.Monad.IO.Unlift+import           Control.Monad.Trans.Control+import           RFC.Prelude+import           UnliftIO.Concurrent  -- |Executes all the IO actions simultaneously and returns the original data structure with the arguments replaced --  by the results of the execution.-doConcurrently :: (Traversable t, MonadBaseControl IO m) => t (m a) -> m (t a)+doConcurrently :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) doConcurrently = mapConcurrently id  -- |Executes all the IO actions simulataneously and discards the results.-doConcurrently_ :: (Foldable f, MonadBaseControl IO m) => f (m a) -> m ()+doConcurrently_ :: (Foldable f, MonadUnliftIO m) => f (m a) -> m () doConcurrently_ = mapConcurrently_ id  -- |Executes all the IO actions simultaneously, feeds them into the filter function, and then -- filters the results.-filterConcurrently :: (MonadBaseControl IO m) => (a -> Bool) -> [m a] -> m [a] -- TODO Seems like we should be able to do this with Foldable/Traversable+filterConcurrently :: (MonadUnliftIO m) => (a -> Bool) -> [m a] -> m [a] -- TODO Seems like we should be able to do this with Foldable/Traversable filterConcurrently filterFunc actions =     filter filterFunc <$> doConcurrently actions

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}@@ -6,12 +7,27 @@   module RFC.Data.ListMoveDirection ) where -import           Data.Aeson  as Aeson-import           Data.Text   as Text+import           Data.Aeson         as Aeson+import           Data.Text          as Text import           RFC.Prelude +#ifndef GHCJS_BROWSER++import           RFC.Servant.ApiDoc (ToSchemaRFC)+import           Servant.Docs++instance ToSample ListMoveDirection where+  toSamples _ =+    [ ("Up/forward/towards head", TowardsHead)+    , ("Down/backward/towards tail", TowardsTail)+    ]++instance ToSchemaRFC ListMoveDirection where++#endif+ data ListMoveDirection = TowardsHead | TowardsTail-  deriving (Show,Eq,Ord,Generic,Typeable)+  deriving (Show,Eq,Ord,Enum,Bounded,Generic,Typeable)  instance FromJSON ListMoveDirection where     parseJSON = withText "ListMoveDirection" $ \t -> do@@ -29,6 +45,9 @@          "-1" -> head         "+1" -> tail++        "-" -> head+        "+" -> tail          "TOWARDSSTART" -> head         "TOWARDSTART" -> head

@@ -33,6 +33,14 @@ instance ToCapture (Capture "id" UUID) where   toCapture _ = DocCapture "id" "UUID identifier" +instance ToSample UUID where+  toSamples _ = samples $ catMaybes $ map UUID.fromString $+    [ "cf41ac06-3f70-479c-a2ed-d618a5e6dee2"+    , "26998bb3-d6c6-4f63-8a36-6b81eb6e6de9"+    , "6176b857-e461-4f34-a6a6-aeb8cbf7ffdf"+    , "26009820-d2d1-4360-87e0-aa73db3c0433"+    ]+ #endif  #ifndef GHCJS_BROWSER@@ -76,3 +84,4 @@  instance ConvertibleStrings UUID LazyByteString where   convertString = UUID.toLazyASCIIBytes+

@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-}  module RFC.Env   ( readGoogleMapsAPIKey@@ -6,6 +6,8 @@   , readEnvironment   , readPsqlConnectInfo   , readRedisConnectInfo+  , readHost+  , readPort   ) where  import           Data.Word                  (Word16)@@ -102,12 +104,23 @@ readRedisPassword = do   result <- readEnv "REDIS_PASSWORD" $ Just ""   return $-    case result of-      "" -> Nothing-      _  -> Just $ cs result+    case null result of+      True  -> Nothing+      False -> Just $ cs result  readRedisDbNumber :: (MonadIO m) => m Integer readRedisDbNumber = read <$> readEnv "REDIS_DATABASE" (Just $ show $ Redis.connectDatabase Redis.defaultConnectInfo)  readAppSlug :: (MonadIO m) => m String readAppSlug = readEnv "APP_SLUG" Nothing++readHost :: (MonadIO m) => m String+readHost =+  forDevOnly "localhost" >>= readEnv "HOST"++readPort :: (MonadIO m) => Word16 -> m Word16+readPort devPort = do+  defaultPort <- forDevOnly $ show devPort+  result <- readEnv "PORT" defaultPort+  return $ (read result :: Word16)+

@@ -26,22 +26,22 @@ import           Network.Wreq.Session      hiding (withAPISession) import           RFC.JSON                  (FromJSON, decodeOrDie) import           RFC.Prelude-import           RFC.String+import           RFC.String                ()  rfcManagerSettings :: ManagerSettings rfcManagerSettings = tlsManagerSettings -createRfcManager :: IO Manager-createRfcManager = newManager rfcManagerSettings+createRfcManager :: (MonadIO m) => m Manager+createRfcManager = liftIO $ newManager rfcManagerSettings -withAPISession :: (Session -> IO a) -> IO a-withAPISession = (>>=) $ newSessionControl Nothing rfcManagerSettings+withAPISession :: (MonadIO m) => (Session -> m a) -> m a+withAPISession = (>>=) $ (liftIO $ newSessionControl Nothing rfcManagerSettings)  newtype BadStatusException = BadStatusException (Status,URL)   deriving (Show,Eq,Ord,Generic,Typeable) instance Exception BadStatusException -apiExecute :: (MonadThrow m, HasAPIClient m, MonadIO m, ConvertibleString LazyByteString s)  =>+apiExecute :: (HasAPIClient m, MonadUnliftIO m, ConvertibleString LazyByteString s)  =>   URL -> (Session -> String -> IO (Response LazyByteString)) -> (s -> m a) -> m a apiExecute rawUrl action converter = do     session <- getAPIClient@@ -49,14 +49,14 @@     let status = response ^. responseStatus     case status ^. statusCode of       200 -> converter . cs $ response ^. responseBody-      _   -> throwM $ badResponseStatus status+      _   -> throwIO $ badResponseStatus status   where     url = exportURL rawUrl     badResponseStatus status = BadStatusException (status, rawUrl) -apiGet :: (HasAPIClient m, FromJSON a, MonadIO m, MonadCatch m, Exception e) => URL -> (e -> m a) -> m a+apiGet :: (HasAPIClient m, FromJSON a, MonadUnliftIO m, Exception e) => URL -> (e -> m a) -> m a apiGet url onError =-    handle onError $ apiExecute url get decodeOrDie+      handle onError $ apiExecute url get decodeOrDie  class HasAPIClient m where   getAPIClient :: m Session

@@ -66,10 +66,10 @@ newtype DecodeError = DecodeError (LazyByteString, String) deriving (Show,Eq,Ord,Generic,Typeable) instance Exception DecodeError -decodeOrDie :: (FromJSON a, MonadThrow m) => LazyByteString -> m a+decodeOrDie :: (FromJSON a, MonadIO  m) => LazyByteString -> m a decodeOrDie input =   case decodeEither' input of-    Left err -> throwM $ DecodeError (input, err)+    Left err -> throwIO $ DecodeError (input, err)     Right a  -> return a  instance FromHttpApiData JSON.Value where

@@ -11,18 +11,19 @@ import           Control.Logger.Simple as Log import           RFC.Env               as Env import           RFC.Prelude-import           System.IO             (BufferMode (..), hSetBuffering, stderr)+import           System.IO             (BufferMode (..), stderr) -withLogging :: IO a -> IO a+withLogging :: (MonadUnliftIO m) => m a -> m a withLogging action = do   isDev <- Env.isDevelopment   hSetBuffering stderr LineBuffering-  Log.withGlobalLogging (logConfig isDev) action+  ioAction <- toIO action+  liftIO $ Log.withGlobalLogging (logConfig isDev) ioAction   where     logConfig isDev =       if isDev then           Log.LogConfig { Log.lc_file = Nothing, Log.lc_stderr = True }       else-          Log.LogConfig { Log.lc_file = Just "./log/api-server.log", Log.lc_stderr = False }+          Log.LogConfig { Log.lc_file = Just "./log/server.log", Log.lc_stderr = False }  

@@ -7,6 +7,7 @@  module RFC.Miso.String   ( module RFC.Miso.String+  , module Miso.String   ) where  import           Data.Function           (id, (.))

@@ -12,14 +12,17 @@   , module Data.Bifunctor   , module Data.Bifoldable   , module Data.Default-  , module Control.Monad.Trans.Control-  , module Control.Concurrent.Lifted   , module ClassyPrelude+  , module Control.Monad.Trans.Control+  , module UnliftIO.Exception+  , module Control.Monad.IO.Unlift+  , module RFC.String+  , module Data.Word   ) where  import           ClassyPrelude               hiding (Day, unpack)-import           Control.Concurrent.Lifted   hiding (throwTo) import           Control.Monad               (forever, void, (<=<), (>=>))+import           Control.Monad.IO.Unlift import           Control.Monad.Trans.Control import           Data.Bifoldable import           Data.Bifunctor@@ -32,9 +35,12 @@                                               StrictByteString, StrictText, cs) import           Data.Time.Units import           Data.Typeable               (TypeRep, typeOf)+import           Data.Word                   (Word16) import           GHC.Generics                (Generic) import           RFC.Data.UUID               (UUID)+import           RFC.String import           Text.Read                   (Read, read)+import           UnliftIO.Exception  charIsUpper :: Char -> Bool charIsUpper = Char.isUpper@@ -48,5 +54,6 @@ safeHead :: [a] -> Maybe a safeHead []    = Nothing safeHead (x:_) = Just x+  type Boolean = Bool -- I keep forgetting which Haskell uses....

@@ -14,14 +14,14 @@ import qualified Database.Redis as R import           RFC.Env        as Env import           RFC.Prelude-import           RFC.String+import           RFC.String     ()  type ConnectionPool = R.Connection  newtype RedisException = RedisException R.Reply deriving (Typeable, Show) instance Exception RedisException -class (MonadThrow m, MonadIO m) => HasRedis m where+class (MonadUnliftIO m) => HasRedis m where   getRedisPool :: m ConnectionPool    runRedis :: R.Redis a -> m a@@ -29,7 +29,7 @@     conn <- getRedisPool     liftIO $ R.runRedis conn r -createConnectionPool :: (MonadIO m) => m ConnectionPool+createConnectionPool :: (MonadUnliftIO m) => m ConnectionPool createConnectionPool = do   connInfo <- Env.readRedisConnectInfo   liftIO $ R.connect connInfo@@ -40,8 +40,8 @@   maybeResult <- unpack result   return $ cs <$> maybeResult -unpack :: (MonadThrow m) => Either R.Reply a -> m a-unpack (Left reply) = throw $ RedisException reply+unpack :: (MonadUnliftIO m) => Either R.Reply a -> m a+unpack (Left reply) = throwIO $ RedisException reply unpack (Right it)   = return it  setex :: (HasRedis m, ConvertibleToSBS key, ConvertibleToSBS value, TimeUnit expiry) => key -> value -> expiry -> m ()

@@ -24,7 +24,7 @@   , module RFC.API   ) where -import           Control.Monad.Catch        (handleJust)+import           Control.Natural            (type (~>)) import           Data.Aeson                 as JSON import qualified Data.Aeson.Diff            as JSON import           Data.Swagger               (Swagger, ToSchema)@@ -34,12 +34,13 @@ import           RFC.Data.IdAnd import           RFC.HTTP.Client import           RFC.JSON                   ()-import           RFC.Prelude                hiding (Handler, handleJust)+import           RFC.Prelude                hiding (Handler) import qualified RFC.Psql                   as Psql import qualified RFC.Redis                  as Redis import           Servant import           Servant.Docs               hiding (API) import           Servant.HTML.Blaze         (HTML)+import           Servant.Server             (Handler, runHandler) import           Text.Blaze.Html  type ApiCtx =@@ -50,6 +51,14 @@       )     ) +instance {-# OVERLAPPABLE #-} MonadUnliftIO Handler where+  askUnliftIO = return $ UnliftIO $ \handler -> do+    either <- runHandler handler+    case either of+      Left err -> throwIO err+      Right v  -> return v++ instance HasAPIClient ApiCtx where   getAPIClient = ask @@ -59,12 +68,10 @@ instance Redis.HasRedis ApiCtx where   getRedisPool = lift $ lift ask -type (:~>) a b = forall x. a x -> b x--apiCtxToHandler :: Wreq.Session -> Redis.ConnectionPool -> Psql.ConnectionPool -> ApiCtx :~> Handler+apiCtxToHandler :: Wreq.Session -> Redis.ConnectionPool -> Psql.ConnectionPool -> ApiCtx ~> Handler apiCtxToHandler apiClient redisPool psqlPool = toHandler   where-    toHandler :: ApiCtx :~> Handler+    toHandler :: ApiCtx ~> Handler     toHandler = withRedis . withPsql . withAPIClient       where         withAPIClient m = runReaderT m apiClient@@ -162,7 +169,7 @@ handleDupes =     handleJust isDuplicate throwUp   where-    throwUp err = throw $ err409+    throwUp err = throwIO $ err409       { errReasonPhrase = cs $ sqlErrorMsg err       , errBody = cs $ sqlErrorDetail err       }

@@ -1,26 +1,39 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DefaultSignatures     #-} {-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude     #-} {-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE UndecidableInstances  #-}  module RFC.Servant.ApiDoc   ( apiToHtml   , apiToAscii   , apiToSwagger   , apiApplication+  , swaggerSchemaOptions+  , ToSchemaRFC   ) where +import qualified Data.Aeson                      as Aeson import           Data.Aeson.Types                (fromEncoding, toEncoding) import qualified Data.Binary.Builder             as Builder import           Data.Char                       as Char import           Data.Default                    (def) import           Data.Monoid                     ((<>))+import           Data.Swagger+import           Data.Swagger.Declare+import           Data.Swagger.Internal.Schema    (GToSchema)+import           Data.Swagger.Internal.TypeShape (TypeHasSimpleShape)+import           GHC.Generics                    (Rep) import           Network.HTTP.Types.Header       (hContentType) import           Network.HTTP.Types.Status import           Network.Wai+import           RFC.JSON                        (jsonOptions) import           RFC.Prelude                     hiding ((<>)) import           RFC.Servant-import           RFC.String+import           RFC.String                      () import           Servant.Swagger import qualified Text.Blaze.Html.Renderer.String as Blaze import qualified Text.Markdown                   as MD@@ -79,3 +92,27 @@     failPathNotFound = callback $       responseLBS status404 [(hContentType, cs "text/plain")] (cs $ "Path not found: " ++ pathInfo) ++instance ToSample () where+  toSamples _ = [(cs "No value", ())]++swaggerSchemaOptions :: SchemaOptions+swaggerSchemaOptions = SchemaOptions+  { fieldLabelModifier = Aeson.fieldLabelModifier jsonOptions+  , constructorTagModifier = Aeson.constructorTagModifier jsonOptions+  , unwrapUnaryRecords = Aeson.unwrapUnaryRecords jsonOptions+  , datatypeNameModifier = id+  , allNullaryToStringTag = True+  }++class ToSchemaRFC a where+  declareNamedSchemaRFC :: proxy a -> Declare (Definitions Schema) NamedSchema+  default declareNamedSchemaRFC ::+    (Generic a+    , GToSchema (Rep a)+    , TypeHasSimpleShape a "genericDeclareNamedSchemaUnrestricted"+    ) => proxy a -> Declare (Definitions Schema) NamedSchema+  declareNamedSchemaRFC = genericDeclareNamedSchema swaggerSchemaOptions++instance {-# OVERLAPPABLE #-} ToSchemaRFC a => ToSchema a where+  declareNamedSchema = declareNamedSchemaRFC

@@ -1,5 +1,7 @@-{-# LANGUAGE ConstraintKinds  #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeSynonymInstances #-}  module RFC.String   ( module RFC.String@@ -11,6 +13,10 @@ import           Data.String.Conversions             hiding ((<>)) import           Data.String.Conversions.Monomorphic hiding (fromString,                                                       toString)+#ifndef GHCJS_BROWSER+import           Data.Function                       (($))+import           Servant.Docs+#endif  type ConvertibleString = ConvertibleStrings -- I keep forgetting to pluralize this. type ConvertibleToSBS a = ConvertibleStrings a StrictByteString@@ -18,4 +24,12 @@ type ConvertibleToString a = ConvertibleStrings a String type ConvertibleFromString a = ConvertibleStrings String a +#ifndef GHCJS_BROWSER +instance ToSample StrictText where+  toSamples _ = singleSample $ cs "This is random text"++instance ToSample LazyText where+  toSamples _ = singleSample $ cs "This is random text"++#endif