diff --git a/rfc.cabal b/rfc.cabal --- a/rfc.cabal +++ b/rfc.cabal @@ -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 diff --git a/src/RFC/Client/Coinhive.hs b/src/RFC/Client/Coinhive.hs --- a/src/RFC/Client/Coinhive.hs +++ b/src/RFC/Client/Coinhive.hs @@ -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 diff --git a/src/RFC/Concurrent.hs b/src/RFC/Concurrent.hs --- a/src/RFC/Concurrent.hs +++ b/src/RFC/Concurrent.hs @@ -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 diff --git a/src/RFC/Data/ListMoveDirection.hs b/src/RFC/Data/ListMoveDirection.hs --- a/src/RFC/Data/ListMoveDirection.hs +++ b/src/RFC/Data/ListMoveDirection.hs @@ -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 diff --git a/src/RFC/Data/UUID.hs b/src/RFC/Data/UUID.hs --- a/src/RFC/Data/UUID.hs +++ b/src/RFC/Data/UUID.hs @@ -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 + diff --git a/src/RFC/Env.hs b/src/RFC/Env.hs --- a/src/RFC/Env.hs +++ b/src/RFC/Env.hs @@ -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) + diff --git a/src/RFC/HTTP/Client.hs b/src/RFC/HTTP/Client.hs --- a/src/RFC/HTTP/Client.hs +++ b/src/RFC/HTTP/Client.hs @@ -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 diff --git a/src/RFC/JSON.hs b/src/RFC/JSON.hs --- a/src/RFC/JSON.hs +++ b/src/RFC/JSON.hs @@ -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 diff --git a/src/RFC/Log.hs b/src/RFC/Log.hs --- a/src/RFC/Log.hs +++ b/src/RFC/Log.hs @@ -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 } diff --git a/src/RFC/Miso/String.hs b/src/RFC/Miso/String.hs --- a/src/RFC/Miso/String.hs +++ b/src/RFC/Miso/String.hs @@ -7,6 +7,7 @@ module RFC.Miso.String ( module RFC.Miso.String + , module Miso.String ) where import Data.Function (id, (.)) diff --git a/src/RFC/Prelude.hs b/src/RFC/Prelude.hs --- a/src/RFC/Prelude.hs +++ b/src/RFC/Prelude.hs @@ -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.... diff --git a/src/RFC/Redis.hs b/src/RFC/Redis.hs --- a/src/RFC/Redis.hs +++ b/src/RFC/Redis.hs @@ -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 () diff --git a/src/RFC/Servant.hs b/src/RFC/Servant.hs --- a/src/RFC/Servant.hs +++ b/src/RFC/Servant.hs @@ -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 } diff --git a/src/RFC/Servant/ApiDoc.hs b/src/RFC/Servant/ApiDoc.hs --- a/src/RFC/Servant/ApiDoc.hs +++ b/src/RFC/Servant/ApiDoc.hs @@ -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 diff --git a/src/RFC/String.hs b/src/RFC/String.hs --- a/src/RFC/String.hs +++ b/src/RFC/String.hs @@ -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