rfc 0.0.0.24 → 0.0.0.25
raw patch · 28 files changed
+946/−742 lines, 28 filesdep +bytestringdep +envydep +mono-traversabledep −freer-simpledep −postgresql-simpledep −string-conversionsdep ~aeson-diffdep ~lensdep ~miso
Dependencies added: bytestring, envy, mono-traversable, mtl, network, postgresql-typed, text-conversions, time, wai-cli, warp
Dependencies removed: freer-simple, postgresql-simple, string-conversions, vector
Dependency ranges changed: aeson-diff, lens, miso
Files
- rfc.cabal +43/−33
- src/RFC/API.hs +6/−1
- src/RFC/Client/Coinhive.hs +0/−91
- src/RFC/Concurrent.hs +26/−8
- src/RFC/Data/IdAnd.hs +8/−18
- src/RFC/Data/LatLng.hs +0/−30
- src/RFC/Data/ListMoveDirection.hs +33/−23
- src/RFC/Data/UUID.hs +42/−34
- src/RFC/Env.hs +92/−98
- src/RFC/GHCJS.hs +12/−0
- src/RFC/GHCJS/Cookie.hs +29/−0
- src/RFC/GHCJS/Inject.hs +75/−0
- src/RFC/GHCJS/XHR.hs +7/−0
- src/RFC/JSON.hs +5/−3
- src/RFC/Log.hs +7/−7
- src/RFC/Miso.hs +0/−12
- src/RFC/Miso/Inject.hs +0/−15
- src/RFC/Miso/Routing.hs +0/−151
- src/RFC/Miso/String.hs +64/−36
- src/RFC/Miso/XHR.hs +0/−7
- src/RFC/Prelude.hs +83/−18
- src/RFC/Psql.hs +78/−79
- src/RFC/Redis.hs +26/−6
- src/RFC/Servant.hs +35/−38
- src/RFC/Servant/ApiDoc.hs +9/−16
- src/RFC/String.hs +206/−15
- src/RFC/Throttle.hs +2/−0
- src/RFC/Wai.hs +58/−3
rfc.cabal view
@@ -1,5 +1,5 @@ name: rfc-version: 0.0.0.24+version: 0.0.0.25 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@@ -13,10 +13,6 @@ extra-source-files: README.md cabal-version: >=1.10 -Flag Browser- Description: Build assuming GHCJS for the browser.- Default: False- Manual: False Flag Development Description: Turn on errors for warnings@@ -27,40 +23,48 @@ hs-source-dirs: src build-depends: base >= 4.7 && < 5 default-language: Haskell2010- default-extensions: NoImplicitPrelude- ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-tabs+ default-extensions: RebindableSyntax+ , MonadFailDesugaring+ , MultiParamTypeClasses+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans+ ghc-options: -fno-max-relevant-binds -fprint-potential-instances -Wno-missing-monadfail-instances+ ghc-options: -fno-warn-name-shadowing -fno-warn-tabs -Wnoncanonical-monad-instances -Wall-missed-specialisations+ ghc-options: -Wnoncanonical-monadfail-instances -Wimplicit-prelude -Wmissing-exported-signatures -Widentities if flag(Development)- ghc-options: -Werror+ ghc-options: -Werror -dcore-lint -dcmm-lint build-depends: base >= 4.7 && < 5+ , bytestring >= 0.10.8.1 , classy-prelude >= 1.4 , uuid-types , containers , unordered-containers- , string-conversions- , resource-pool+ , text-conversions >= 0.3.0 , data-default- , lens+ , lens >= 4.16 , http-types , http-api-data >= 0.3.7.1 , time-units- , aeson-diff- , vector , text- , bifunctors , 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- , url , network-uri- if flag(Browser)- build-depends: aeson , attoparsec- , miso >= 0.12.0.0+ , resource-pool+ , time+ , aeson-diff >= 1.1.0.4+ , mtl+ , miso >= 0.14.0.0+ , url+ , mono-traversable >= 1.0.1.1+ if impl(ghcjs)+ build-depends: aeson+ , bifunctors+ -- Servant 0.13 publishes non-GHCJS-compatible Aeson version requirement. , servant >= 0.12.1 && < 0.13- if !flag(Browser)+ else build-depends: servant-server >= 0.13 , servant >= 0.13 , servant-docs >= 0.11.2@@ -70,7 +74,9 @@ , aeson >= 1.2.3.0 , wai-extra , wai-cors- , postgresql-simple >= 0.5.3.0+ , wai-cli >= 0.1.1+ , envy >= 1.5.0.0+ , postgresql-typed >= 0.5.2 , hedis >= 0.10.0 , simple-logger , temporary@@ -82,7 +88,9 @@ , markdown , servant-client >= 0.13 , binary-+ , network+ , warp >= 3.2.18+ , mtl >= 2.2.2 exposed-modules: RFC.Prelude , RFC.String , RFC.Concurrent@@ -94,24 +102,26 @@ , RFC.Data.IdAnd , RFC.Data.ListMoveDirection , RFC.Data.UUID- if flag(Browser)- exposed-modules: RFC.Miso , RFC.Miso.String- , RFC.Miso.XHR- , RFC.Miso.Inject- , RFC.Miso.Routing- if !flag(Browser)- exposed-modules: RFC.Psql+ -- , RFC.Miso.Component+ -- , RFC.Miso.Routing+ -- , RFC.Miso.MisoApp+ if impl(ghcjs)+ cpp-options: -DGHCJS -DCLIENT -DGHCJS_BROWSER -DBROWSER+ exposed-modules: RFC.GHCJS+ , RFC.GHCJS.XHR+ , RFC.GHCJS.Inject+ , RFC.GHCJS.Cookie+ else+ exposed-modules: RFC.Log+ , RFC.Psql , RFC.Redis- , RFC.Log , RFC.Wai , RFC.Env , RFC.HTTP.Client , RFC.Servant , RFC.Servant.ApiDoc- , RFC.Client.Coinhive- if flag(Browser)- cpp-options: -DCLIENT -DGHCJS_BROWSER -DBROWSER+ -- , RFC.Client.Coinhive source-repository head
src/RFC/API.hs view
@@ -3,7 +3,12 @@ {-# LANGUAGE TemplateHaskell #-} module RFC.API- ( module RFC.API+ ( JDelete+ , JGet+ , JPatch+ , JPost+ , JPut+ , JReqBody ) where import RFC.Prelude ()
− src/RFC/Client/Coinhive.hs
@@ -1,91 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeOperators #-}---- |Client to access API of Coinhive: https://coinhive.com/documentation/http-api-module RFC.Client.Coinhive- ( module RFC.Client.Coinhive- ) where--import RFC.Prelude--import Data.Aeson.Types as JSON-import RFC.API-import RFC.HTTP.Client (HasHttpManager (..))-import RFC.JSON-import Servant--#ifndef GHCJS_BROWSER-import Servant.Client-#endif---- |The secret key given by CoinHive to the client, WHICH SHOULD NEVER BE SHARED.-newtype SecretKey = SecretKey String deriving (FromJSON,ToJSON,ToHttpApiData,FromHttpApiData)---- |The token id that a user has, which we want to verify.-newtype TokenId = TokenId String deriving (FromJSON,ToJSON,ToHttpApiData,FromHttpApiData)---- |Response from a token verification request.-data TokenVerification = TokenVerification- { tvSuccess :: Bool- , tvHashes :: Integer- , tvCreated :: Integer- , tvError :: Maybe String- }-$(deriveJSON jsonOptions ''TokenVerification)---- |Arguments required to request verification of a token.-data TokenVerifyRequest = TokenVerifyRequest- { tvrSecret :: SecretKey- , tvrToken :: TokenId- , tvrHashes :: Integer- }-$(deriveJSON jsonOptions ''TokenVerifyRequest)---- |The proxy so that you can refer to the API type.-api :: Proxy API-api = Proxy---- |The unification of the various endpoints.-type API =- TokenVerify---- |Endpoint to request verification of a token-type TokenVerify =- "token" :> "verify" :> JReqBody TokenVerifyRequest :> JPost TokenVerification--#ifndef GHCJS_BROWSER---- |Monad defining how to request a token verification. See 'tokenVerify' instead: that's probably what you want.-tokenVerifyM :: TokenVerifyRequest -> ClientM TokenVerification-tokenVerifyM- = client api---- |Base URL for CoinHive's API-apiUrlBase :: BaseUrl-apiUrlBase = BaseUrl- { baseUrlScheme = Https- , baseUrlHost = "api.coinhive.com"- , baseUrlPort = 443- , baseUrlPath = "/"- }---- |Perform a verification of a token.-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 -> throwIO err- Right response -> return response- where- baseUrl = apiUrlBase- cookieJar = Nothing--#endif
src/RFC/Concurrent.hs view
@@ -1,33 +1,51 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-} module RFC.Concurrent ( module RFC.Concurrent , module Control.Monad.IO.Unlift , module UnliftIO.Concurrent- , module Control.Concurrent.Async.Lifted+ , module UnliftIO.Async , module Control.Monad.Trans.Control ) where -import Control.Concurrent.Async.Lifted hiding (mapConcurrently,- mapConcurrently_) import Control.Monad.IO.Unlift import Control.Monad.Trans.Control+import Data.Foldable (foldrM) import RFC.Prelude+import UnliftIO.Async 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, MonadUnliftIO m) => t (m a) -> m (t a) doConcurrently = mapConcurrently id+{-# SPECIALIZE INLINE doConcurrently :: (MonadUnliftIO m) => [m a] -> m [a] #-}+{-# SPECIALIZE INLINE doConcurrently :: [IO a] -> IO [a] #-}+{-# INLINE doConcurrently #-} -- |Executes all the IO actions simulataneously and discards the results. doConcurrently_ :: (Foldable f, MonadUnliftIO m) => f (m a) -> m () doConcurrently_ = mapConcurrently_ id+{-# SPECIALIZE INLINE doConcurrently_ :: (MonadUnliftIO m) => [m a] -> m () #-}+{-# SPECIALIZE INLINE doConcurrently_ :: [IO a] -> IO () #-}+{-# INLINE doConcurrently_ #-} --- |Executes all the IO actions simultaneously, feeds them into the filter function, and then--- filters the results.-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+-- |Executes all the IO actions simultaneously and then filters the results based on the filter function.+filterConcurrently :: (Traversable t, Applicative t, Monoid (t a), MonadUnliftIO m) => (a -> Bool) -> t (m a) -> m (t a)+filterConcurrently test actions = do+ !asyncActions <- mapM async actions+ foldrM foldImpl mempty asyncActions+ where+ foldImpl !promise results = do+ result <- wait promise+ return $ if test result then+ (pure result) `mappend` results+ else+ results+{-# INLINABLE filterConcurrently #-}+{-# SPECIALIZE INLINE filterConcurrently :: (MonadUnliftIO m) => (a -> Bool) -> [m a] -> m [a] #-}+{-# SPECIALIZE INLINE filterConcurrently :: (a -> Bool) -> [IO a] -> IO [a] #-}
src/RFC/Data/IdAnd.hs view
@@ -27,27 +27,23 @@ import RFC.Prelude -import Data.Aeson as JSON-import qualified Data.List as List hiding ((++))-import qualified Data.Map as Map-import qualified Data.UUID.Types as UUID+import Data.Aeson as JSON+import qualified Data.List as List hiding ((++))+import qualified Data.Map as Map+import qualified Data.UUID.Types as UUID #if MIN_VERSION_aeson(1,0,0) -- Don't need the backflips for maps #else-import Data.Aeson.Types (Parser, typeMismatch)+import Data.Aeson.Types (Parser, typeMismatch) -- import Data.Bitraversable-import qualified Data.HashMap.Lazy as HashMap+import qualified Data.HashMap.Lazy as HashMap #endif #ifndef GHCJS_BROWSER-import Control.Lens hiding ((.=))-import Data.Proxy (Proxy (..))+import Control.Lens hiding ((.=))+import Data.Proxy (Proxy (..)) import Data.Swagger-import Database.PostgreSQL.Simple.FromField ()-import Database.PostgreSQL.Simple.FromRow-import Database.PostgreSQL.Simple.ToField-import Database.PostgreSQL.Simple.ToRow import Servant.Docs #endif @@ -126,12 +122,6 @@ #endif #ifndef GHCJS_BROWSER-instance (FromRow a) => FromRow (IdAnd a) where- fromRow = valuesToIdAnd <$> field <*> fromRow--instance (ToRow a) => ToRow (IdAnd a) where- toRow (IdAnd (id,a)) = toField id : toRow a- instance (ToSchema a, ToJSON a, ToSample a) => ToSchema (IdAnd a) where declareNamedSchema _ = do NamedSchema{..} <- declareNamedSchema (Proxy :: Proxy a)
src/RFC/Data/LatLng.hs view
@@ -15,9 +15,6 @@ import RFC.JSON as JSON import RFC.Prelude-#ifndef GHCJS_BROWSER-import RFC.Psql as Psql-#endif type Latitude = Double type Longitude = Double@@ -28,33 +25,6 @@ longitude :: Longitude } deriving (Eq, Ord, Show, Typeable, Generic) $(JSON.deriveJSON JSON.jsonOptions ''LatLng)--#ifndef GHCJS_BROWSER-noLat :: Maybe Latitude-noLat = Nothing--noLng :: Maybe Longitude-noLng = Nothing--instance ToRow LatLng where- toRow latLng = Psql.toRow (latitude latLng, longitude latLng)--instance ToRow (Maybe LatLng) where- toRow maybeLatLng =- case maybeLatLng of- Nothing -> map toField [noLat, noLng]- (Just latLng) -> Psql.toRow latLng--instance FromRow LatLng where- fromRow = latLng <$> Psql.field <*> Psql.field--instance FromRow (Maybe LatLng) where- fromRow = do- parsed <- (fromRow :: RowParser (Maybe (Maybe Latitude, Maybe Longitude)))- case parsed of- (Just (Just lat, Just lng)) -> return $ Just $ latLng lat lng- _ -> return Nothing-#endif latLng :: Latitude -> Longitude -> LatLng latLng lat lng = LatLng lat lng
src/RFC/Data/ListMoveDirection.hs view
@@ -7,14 +7,14 @@ module RFC.Data.ListMoveDirection ) where -import Data.Aeson as Aeson-import Data.Text as Text-import RFC.Prelude+import Data.Aeson as Aeson+import Data.Text as Text+import RFC.Prelude #ifndef GHCJS_BROWSER -import RFC.Servant.ApiDoc (ToSchemaRFC)-import Servant.Docs+import RFC.Servant.ApiDoc ( ToSchemaRFC )+import Servant.Docs instance ToSample ListMoveDirection where toSamples _ =@@ -26,6 +26,16 @@ #endif +moveInList :: (Eq a) => a -> ListMoveDirection -> [a] -> [a]+moveInList target dir lst =+ case (lst,dir) of+ ([], _) -> []+ ((_:[]), _) -> lst+ ((a:b:rest), TowardsHead) | b == target -> b:a:rest+ ((a:b:rest), TowardsTail) | a == target -> b:a:rest+ ((_:b:rest), _) -> moveInList target dir (b:rest)++ data ListMoveDirection = TowardsHead | TowardsTail deriving (Show,Eq,Ord,Enum,Bounded,Generic,Typeable) @@ -34,35 +44,35 @@ let head = return TowardsHead let tail = return TowardsTail case Text.strip $ Text.toUpper t of- "UP" -> head- "DOWN" -> tail+ "UP" -> head+ "DOWN" -> tail - "FORWARD" -> head- "BACKWARD" -> tail+ "FORWARD" -> head+ "BACKWARD" -> tail - "FRONT" -> head- "BACK" -> tail+ "FRONT" -> head+ "BACK" -> tail - "-1" -> head- "+1" -> tail+ "-1" -> head+ "+1" -> tail - "-" -> head- "+" -> tail+ "-" -> head+ "+" -> tail "TOWARDSSTART" -> head- "TOWARDSTART" -> head- "TOWARDSEND" -> tail+ "TOWARDSTART" -> head+ "TOWARDSEND" -> tail "TOWARDSFRONT" -> head- "TOWARDSBACK" -> tail+ "TOWARDSBACK" -> tail - "TOWARDSHEAD" -> head- "TOWARDSTAIL" -> tail+ "TOWARDSHEAD" -> head+ "TOWARDSTAIL" -> tail - "HEADWARDS" -> head- "TAILWARDS" -> tail+ "HEADWARDS" -> head+ "TAILWARDS" -> tail - _ -> fail . cs $ Text.append "Could not parse string to direction: " t+ _ -> fail . cs $ Text.append "Could not parse string to direction: " t instance ToJSON ListMoveDirection where toJSON dir = Aeson.String (
src/RFC/Data/UUID.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -9,22 +10,22 @@ ( module Data.UUID.Types ) where -import ClassyPrelude+import ClassyPrelude hiding (fail)+import Control.Monad.Fail (MonadFail, fail) import RFC.String -import Data.UUID.Types-import qualified Data.UUID.Types as UUID+import Data.UUID.Types hiding (fromString)+import qualified Data.UUID.Types as UUID #if MIN_VERSION_aeson(1,1,0) -- UUID has ToJSON and FromJSON #else-import Data.Aeson.Types+import Data.Aeson.Types (FromJSON (..), ToJSON (..),+ Value (String), typeMismatch)+import qualified Data.Text as T #endif #ifndef GHCJS_BROWSER-import Database.PostgreSQL.Simple.FromRow-import Database.PostgreSQL.Simple.ToRow-import Database.PostgreSQL.Simple.Types (Only (..)) import Servant.API.Capture import Servant.Docs #endif@@ -43,45 +44,52 @@ #endif -#ifndef GHCJS_BROWSER-instance FromRow UUID where- fromRow = do- (Only id) <- fromRow- return id--instance ToRow UUID where- toRow id = toRow $ Only id-#endif- #if MIN_VERSION_aeson(1,1,0) -- UUID has ToJSON and FromJSON #else instance ToJSON UUID where- toJSON = toJSON . UUID.toText+ toJSON = String . T.pack . show+ {-# INLINE toJSON #-} instance FromJSON UUID where- parseJSON (String txt) =- case UUID.fromText txt of- Nothing -> fail $ "Invalid UUID: " ++ cs txt- Just uuid -> return uuid-- parseJSON invalid = typeMismatch "UUID" invalid+ parseJSON json@(String t) =+ case UUID.fromText t of+ Just uuid -> pure uuid+ Nothing -> typeMismatch "UUID" json+ parseJSON unknown = typeMismatch "UUID" unknown+ {-# INLINE parseJSON #-} #endif -instance ConvertibleStrings UUID String where- convertString = UUID.toString+instance {-# OVERLAPPING #-} ToText UUID where+ toText = UUID.toText+ {-# INLINE toText #-} -instance ConvertibleStrings UUID StrictText where- convertString = UUID.toText+instance {-# OVERLAPS #-} (MonadFail m) => FromText (m UUID) where+ {-# SPECIALISE instance FromText (Maybe UUID) #-}+ {-# SPECIALISE instance FromText ([UUID]) #-}+ {-# SPECIALISE instance FromText (IO UUID) #-}+ fromText :: Text -> m UUID+ fromText text =+ case UUID.fromText text of+ Nothing -> fail $ "Could not parse UUID: " ++ (cs text)+ Just x -> return x+ {-# INLINE fromText #-} -instance ConvertibleStrings UUID LazyText where- convertString = toLazyText+instance {-# OVERLAPPING #-} ConvertibleStrings UUID String where+ cs = UUID.toString+ {-# INLINE cs #-} -instance ConvertibleStrings UUID StrictByteString where- convertString = UUID.toASCIIBytes+instance {-# OVERLAPPING #-} ConvertibleStrings UUID StrictText where+ cs = UUID.toText+ {-# INLINE cs #-} -instance ConvertibleStrings UUID LazyByteString where- convertString = UUID.toLazyASCIIBytes+instance {-# OVERLAPPING #-} ConvertibleStrings UUID (UTF8 StrictByteString) where+ cs = UTF8 . UUID.toASCIIBytes+ {-# INLINE cs #-}++instance {-# OVERLAPPING #-} ConvertibleStrings UUID (UTF8 LazyByteString) where+ cs = UTF8 . UUID.toLazyASCIIBytes+ {-# INLINE cs #-}
src/RFC/Env.hs view
@@ -1,126 +1,120 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE InstanceSigs #-} module RFC.Env- ( readGoogleMapsAPIKey- , isDevelopment+ ( isDevelopment , readEnvironment- , readPsqlConnectInfo- , readRedisConnectInfo , readHost , readPort+ , readAppSlug+ , forDevOnly+ , envWithDefault+ , envWithDevDefault+ , module System.Envy ) where -import Data.Word (Word16)-import Database.PostgreSQL.Simple as Psql-import Database.Redis as Redis+import Control.Applicative+import Data.Time.Clock+import Data.Word+import Network (PortID (..)) import RFC.Prelude-import System.Environment (lookupEnv)+import System.Environment+import System.Envy+import Text.Read (readMaybe) --- TODO Create a Monad that only logs reading the env var once, and reads all the environment variables at once, and is pure.+envWithDefault :: Var a => String -> a -> Parser a+envWithDefault name defaultValue = fmap (fromMaybe defaultValue) $ envMaybe name+{-# INLINE envWithDefault #-} -readEnv :: (MonadIO m) => String -> Maybe String -> m String-readEnv envKey defaultValue = do- foundValue <- liftIO $ lookupEnv envKey- case foundValue of- Nothing ->- case defaultValue of- Nothing -> fail $ "No value of " ++ (show envKey) ++ " environment variable, and no default configured."- (Just s) -> do- return s- (Just s) -> do- return s+envWithDevDefault :: Var a => String -> a -> Parser a+envWithDevDefault name defaultValue =+ if isDevelopment then+ envWithDefault name defaultValue+ else+ env name+{-# INLINE envWithDevDefault #-} -isDevelopment :: (MonadIO m) => m Bool-isDevelopment = ((==) "development") <$> readEnvironment+isDevelopment :: Bool+isDevelopment =+#ifdef DEVELOPMENT+ True+#else+ False+#endif+{-# INLINE isDevelopment #-} -forDevOnly :: (MonadIO m) => String -> m (Maybe String)-forDevOnly defaultValue = do- isDev <- isDevelopment- return $ if isDev then+forDevOnly :: a -> Maybe a+forDevOnly defaultValue =+ if isDevelopment then Just defaultValue else Nothing+{-# INLINE forDevOnly #-} readEnvironment :: (MonadIO m) => m String-readEnvironment = readEnv "ENV" defaultEnv- where- defaultEnv = Just "development"--readGoogleMapsAPIKey :: (MonadIO m) => m String-readGoogleMapsAPIKey = readEnv "GMAPS_API_KEY" Nothing--readPsqlUser :: (MonadIO m) => m String-readPsqlUser = do- projectThunk <- readAppSlug >>= forDevOnly- readEnv "PSQL_USERNAME" $ projectThunk--readPsqlPassword :: (MonadIO m) => m String-readPsqlPassword = do- projectThunk <- readAppSlug >>= forDevOnly- readEnv "PSQL_PASSWORD" projectThunk--readPsqlDatabase :: (MonadIO m) => m String-readPsqlDatabase = do- projectThunk <- readAppSlug >>= forDevOnly- readEnv "PSQL_DATABASE" projectThunk--readPsqlHost :: (MonadIO m) => m String-readPsqlHost = readEnv "PSQL_HOST" $ Just $ Psql.connectHost Psql.defaultConnectInfo+readEnvironment =+ readEnvWithDefault "ENV" "development"+{-# INLINE readEnvironment #-} -readPsqlPort :: (MonadIO m) => m Word16-readPsqlPort = do- result <- readEnv "PSQL_PORT" $ Just $ show $ Psql.connectPort Psql.defaultConnectInfo- return $ read result+readAppSlug :: (MonadIO m, MonadFail m) => m String+readAppSlug = readEnvWithDevDefault "APP_SLUG" "dev"+{-# INLINE readAppSlug #-} -readPsqlConnectInfo :: (MonadIO m) => m Psql.ConnectInfo-readPsqlConnectInfo =- Psql.ConnectInfo- <$> readPsqlHost- <*> readPsqlPort- <*> readPsqlUser- <*> readPsqlPassword- <*> readPsqlDatabase+readHost :: (MonadIO m, MonadFail m) => m String+readHost =+ readEnvWithDevDefault "HOST" "localhost"+{-# INLINE readHost #-} -readRedisConnectInfo :: (MonadIO m) => m Redis.ConnectInfo-readRedisConnectInfo =- Redis.ConnInfo- <$> readRedisHost- <*> readRedisPort- <*> readRedisPassword- <*> readRedisDbNumber- <*> (return $ Redis.connectMaxConnections Redis.defaultConnectInfo)- <*> (return $ Redis.connectMaxIdleTime Redis.defaultConnectInfo)- <*> (return $ Just 10)+readPort :: (MonadIO m, MonadFail m) => Word16 -> m Word16+readPort devPort = readEnvWithDevDefault "PORT" devPort+{-# INLINE readPort #-} -readRedisHost :: (MonadIO m) => m Redis.HostName-readRedisHost = readEnv "REDIS_HOST" $ Just $ Redis.connectHost Redis.defaultConnectInfo+readEnvWithDefault :: (MonadIO m, Read a) => String -> a -> m a+readEnvWithDefault name defaultValue =+ either (const defaultValue) id <$> readEnv name+{-# INLINE readEnvWithDefault #-} -readRedisPort :: (MonadIO m) => m Redis.PortID-readRedisPort = do- result <- readEnv "REDIS_PORT" $ Just "6379" -- Default Redis port- return $ PortNumber $ read result+readEnvWithDevDefault :: (MonadIO m, MonadFail m, Read a) => String -> a -> m a+readEnvWithDevDefault =+ if isDevelopment then+ readEnvWithDefault+ else+ (\name _ -> readEnvOrDie name)+{-# INLINE readEnvWithDevDefault #-} -readRedisPassword :: (MonadIO m) => m (Maybe ByteString)-readRedisPassword = do- result <- readEnv "REDIS_PASSWORD" $ Just ""- return $- case null result of- True -> Nothing- False -> Just $ cs result+readEnv :: (MonadIO m, Read a) => String -> m (Either String a)+readEnv name = liftIO $ do+ result <- lookupEnv name+ return $ case result >>= readMaybe of+ Nothing -> Left (show result)+ Just goodValue -> Right goodValue+{-# INLINE readEnv #-} -readRedisDbNumber :: (MonadIO m) => m Integer-readRedisDbNumber = read <$> readEnv "REDIS_DATABASE" (Just $ show $ Redis.connectDatabase Redis.defaultConnectInfo)+readEnvOrDie :: (MonadIO m, MonadFail m, Read a) => String -> m a+readEnvOrDie name = do+ maybeResult <- readEnv name+ case maybeResult of+ Left err ->+ if err == (show (Nothing::Maybe String)) then+ fail $ "No value set for mandatory environment variable: " ++ name+ else+ fail $ "Cannot use value set for mandatory environment variable: " ++ name ++ " => " ++ err+ Right result -> return result+{-# INLINE readEnvOrDie #-} -readAppSlug :: (MonadIO m) => m String-readAppSlug = readEnv "APP_SLUG" Nothing+instance Var NominalDiffTime where+ toVar :: NominalDiffTime -> String+ toVar = show+ {-# INLINE toVar #-} -readHost :: (MonadIO m) => m String-readHost =- forDevOnly "localhost" >>= readEnv "HOST"+ fromVar :: String -> Maybe NominalDiffTime+ fromVar var = fromInteger <$> readMaybe var+ {-# INLINE fromVar #-} -readPort :: (MonadIO m) => Word16 -> m Word16-readPort devPort = do- defaultPort <- forDevOnly $ show devPort- result <- readEnv "PORT" defaultPort- return $ (read result :: Word16)+instance Var PortID where+ toVar (PortNumber portNum) = toVar $ toInteger portNum+ toVar _ = error "Can only write port numbers to var"+ {-# INLINE toVar #-} + fromVar = (fmap $ PortNumber . fromInteger) . fromVar+ {-# INLINE fromVar #-}
+ src/RFC/GHCJS.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}++module RFC.GHCJS+ ( module RFC.GHCJS.XHR+ , module RFC.GHCJS.Inject+ , module RFC.GHCJS.Cookie+ ) where++import RFC.GHCJS.Cookie+import RFC.GHCJS.Inject+import RFC.GHCJS.XHR
+ src/RFC/GHCJS/Cookie.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module RFC.GHCJS.Cookie+ ( storePermCookie+ , readCookie+ , ghcjsCookieScript+ ) where++import RFC.Miso.String (MisoString)+import RFC.Prelude++ghcjsCookieScript :: String+ghcjsCookieScript = "https://cdn.jsdelivr.net/npm/js-cookie@2/src/js.cookie.min.js"++foreign import javascript safe+ "Cookies.set($1,$2,{expires:500})"+ storePermCookie :: MisoString -> MisoString -> IO ()++readCookie :: (ConvertibleStrings s1 MisoString, ConvertibleStrings MisoString s2) => s1 -> IO (Maybe s2)+readCookie cookieName = do+ raw <- rawReadCookie $ cs cookieName+ return $ case null raw of+ True -> Nothing+ False -> Just $ cs raw++foreign import javascript safe+ "Cookies.get($1) || ''"+ rawReadCookie :: MisoString -> IO MisoString
+ src/RFC/GHCJS/Inject.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}++module RFC.GHCJS.Inject+ ( injectJS+ , injectCSS+ , injectStylesheet+ , injectPreconnectHint+ , injectPreconnectHintURI+ , writeDocumentTitle+ ) where++import Network.URI+import RFC.Miso.String+import RFC.Prelude++-- | Injects a String of CSS declarations as an inline <style type="text/css"> element.+injectStylesheet :: String -> IO ()+injectStylesheet = injectStylesheet' . cs+{-# INLINE injectStylesheet #-}++-- | Injects a reference to a JS file as a <script type="text/javascript"> element.+injectJS :: String -> IO ()+injectJS = injectJS' . cs+{-# INLINE injectJS #-}++-- | Injects a reference to a CSS file as a <link rel="stylesheet"> element.+injectCSS :: String -> IO ()+injectCSS = injectCSS' . cs+{-# INLINE injectCSS #-}++-- | Injects a preconnect hint as a <link rel="preconnect"> element.+injectPreconnectHint :: String -> IO ()+injectPreconnectHint str =+ case parseURI str of+ Nothing -> injectPreconnectHint' str+ Just uri -> injectPreconnectHintURI uri+{-# INLINABLE injectPreconnectHint #-}++-- | Injects a preconnect hint as a <link rel="preconnect"> element.+injectPreconnectHintURI :: URI -> IO ()+injectPreconnectHintURI uri =+ case uriAuthority uri of+ Nothing -> return ()+ Just URIAuth{uriRegName} ->+ injectPreconnectHint uriRegName+{-# INLINABLE injectPreconnectHintURI #-}++injectPreconnectHint' :: String -> IO ()+injectPreconnectHint' "" = return ()+injectPreconnectHint' "localhost" = return ()+injectPreconnectHint' "127.0.0.1" = return ()+injectPreconnectHint' str = injectPreconnectHint'' . cs $ str+{-# INLINE injectPreconnectHint' #-}++foreign import javascript safe+ "if(document.title !== $1) { document.title = $1 };"+ writeDocumentTitle :: MisoString -> IO ()++foreign import javascript safe+ "var script=document.createElement('link');script.rel='preconnect';script.crossorigin=true;script.href='https://' + $1;document.getElementsByTagName('head')[0].appendChild(script);"+ injectPreconnectHint'' :: MisoString -> IO ()++foreign import javascript safe+ "var script=document.createElement('script');script.async='true';script.defer='true';script.type='text/javascript';script.src=$1;document.getElementsByTagName('head')[0].appendChild(script);"+ injectJS' :: MisoString -> IO ()++foreign import javascript safe+ "var ss=document.createElement('link');ss.rel='stylesheet';ss.href=$1;ss.type='text/css';document.getElementsByTagName('head')[0].appendChild(ss);"+ injectCSS' :: MisoString -> IO ()++foreign import javascript safe+ "var ss=document.createElement('style');ss.type='text/css';ss.innerHTML=$1;document.getElementsByTagName('head')[0].appendChild(ss);"+ injectStylesheet' :: MisoString -> IO ()
+ src/RFC/GHCJS/XHR.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}++module RFC.GHCJS.XHR+ ( module RFC.GHCJS.XHR+ ) where++import RFC.Prelude ()
src/RFC/JSON.hs view
@@ -33,6 +33,7 @@ import Data.Aeson.Text as JSON import qualified Data.Aeson.Types as JSONTypes #else+import qualified Data.Aeson.Encode as JSON import Data.Attoparsec.ByteString as JSON import Data.Either (either) #endif@@ -81,9 +82,10 @@ parser = JSONParser.value' parsed = #if MIN_VERSION_aeson(1,0,0)- JSONParser.decodeStrictWith parser JSONTypes.Success (cs text)+ let textBs = asUTF8 text in+ JSONParser.decodeStrictWith parser JSONTypes.Success textBs #else- either (const Nothing) Just $ JSON.parseOnly parser (cs text)+ either (const Nothing) Just $ JSON.parseOnly parser (unUTF8 $ fromText text) #endif instance ToHttpApiData JSON.Value where@@ -91,7 +93,7 @@ #if MIN_VERSION_aeson(1,0,0) cs . JSON.encodeToLazyText #else- cs . JSON.encode+ cs . JSON.encodeToTextBuilder #endif #ifndef GHCJS_BROWSER
src/RFC/Log.hs view
@@ -2,7 +2,7 @@ module RFC.Log ( module Control.Logger.Simple- , module RFC.Log+ , withLogging ) where import Control.Logger.Simple (logDebug, logError, logInfo, logWarn,@@ -13,17 +13,17 @@ import RFC.Prelude import System.IO (BufferMode (..), stderr) -withLogging :: (MonadUnliftIO m) => m a -> m a+withLogging :: (MonadFail m, MonadUnliftIO m) => m a -> m a withLogging action = do- isDev <- Env.isDevelopment+ appSlug <- Env.readAppSlug hSetBuffering stderr LineBuffering ioAction <- toIO action- liftIO $ Log.withGlobalLogging (logConfig isDev) ioAction+ liftIO $ Log.withGlobalLogging (logConfig appSlug) ioAction where- logConfig isDev =- if isDev then+ logConfig appSlug =+ if Env.isDevelopment then Log.LogConfig { Log.lc_file = Nothing, Log.lc_stderr = True } else- Log.LogConfig { Log.lc_file = Just "./log/server.log", Log.lc_stderr = False }+ Log.LogConfig { Log.lc_file = Just ("./log/" ++ appSlug ++ ".log"), Log.lc_stderr = False }
− src/RFC/Miso.hs
@@ -1,12 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}--module RFC.Miso- ( module RFC.Miso.String- , module RFC.Miso.XHR- , module RFC.Miso.Inject- ) where--import RFC.Miso.Inject-import RFC.Miso.String-import RFC.Miso.XHR
− src/RFC/Miso/Inject.hs
@@ -1,15 +0,0 @@-module RFC.Miso.Inject- ( injectJS- , injectCSS- ) where--import Miso.String-import RFC.Prelude--foreign import javascript safe- "var script=document.createElement('script');script.async=true;script.defer=true;script.type='text/javascript';script.src=$1;document.getElementsByTagName('head')[0].appendChild(script);"- injectJS :: MisoString -> IO ()--foreign import javascript safe- "var ss=document.createElement('link');ss.rel='stylesheet';ss.href=$1;ss.type='text/css';document.getElementsByTagName('head')[0].appendChild(ss);"- injectCSS :: MisoString -> IO ()
− src/RFC/Miso/Routing.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}--module RFC.Miso.Routing- ( module RFC.Miso.Routing- , URI(..)- ) where--import Data.Map (Map)-import qualified Data.Map as Map-import Data.Proxy-import Miso.Effect-import Miso.Html (View (..))-import Miso.Subscription.History (URI (..), getCurrentURI)-import qualified Network.URL as URL-import RFC.Prelude--newtype URIHash = URIHash String deriving (Eq)-newtype URIQuery = URIQuery (Map String [String]) deriving (Eq)-type RoutingURI = (URIHash, URIQuery)--parseURI :: URI -> RoutingURI-parseURI URI{uriFragment,uriQuery} =- (URIHash $ parseHash uriFragment, URIQuery $ parseQuery uriQuery)- where- parseHash ('#':rest) = parseHash rest- parseHash ('!':rest) = parseHash rest- parseHash ('/':rest) = parseHash rest- parseHash hash = hash- parseQuery :: String -> Map String [String]- parseQuery ('?':rest) = parseQuery rest- parseQuery query =- case URL.importParams query of- Nothing ->- Map.empty- Just pairs ->- Map.map sort $ Map.fromListWith (++) $ map (second listify) pairs- listify :: String -> [String]- listify "" = []- listify val = [val]--parseCurrentURI :: IO RoutingURI-parseCurrentURI = parseURI <$> getCurrentURI--data ViewSpec parentModel parentAction = ViewSpec (parentModel -> View parentAction, RoutingURI)--instance Eq (ViewSpec model action) where- (==) (ViewSpec(_,left)) (ViewSpec(_,right)) = left == right--class RouteConfig model action- | model -> action, action -> model- where- routeUpdate :: model -> action -> Effect action model- routeView :: model -> View action- runRoute :: model -> RoutingURI -> Maybe (Effect action model)--class (RouteConfig model action, ViewSpecContainer parentModel parentAction)- => RouteConvert parentModel parentAction model action- | parentAction -> parentModel, parentModel -> parentAction- where- wrapAction :: action -> model -> parentAction- unwrapAction :: parentAction -> model -> Maybe action- wrapModel :: parentModel -> model -> parentModel- unwrapModel :: parentModel -> model-- wrapEffect :: parentModel -> Effect action model -> Effect parentAction parentModel- wrapEffect parentModel (Effect model childIOs) =- Effect- (wrapModel parentModel model)- (map (fmap (\act -> wrapAction act model)) childIOs)-- wrappedRunRoute :: Proxy model -> WrappedRun parentModel parentAction- wrappedRunRoute _ uriPair currentParentModel = do- childEffect <- runRoute childSeed uriPair- return $ effectWrapper childEffect (ViewSpec (view, uriPair))- where- childSeed :: model- childSeed = unwrapModel currentParentModel- effectWrapper :: Effect action model -> ViewSpec parentModel parentAction -> Effect parentAction parentModel- effectWrapper childEffect viewSpec = wrapEffect (setViewSpec currentParentModel viewSpec) childEffect- view :: parentModel -> View parentAction- view parentModel = fmap (\action -> wrapAction action childModel) $ routeView childModel- where- childModel :: model- childModel = unwrapModel parentModel-- wrappedRouteUpdate :: Proxy model -> WrappedUpdate parentModel parentAction- wrappedRouteUpdate _ parentModel parentAction =- case unwrapAction parentAction model of- Nothing -> noEff parentModel- Just action -> wrapEffect parentModel $ routeUpdate model action- where- model :: model- model = unwrapModel parentModel--class ViewSpecContainer parentModel parentAction where- setViewSpec :: parentModel -> ViewSpec parentModel parentAction -> parentModel- getViewSpec :: parentModel -> ViewSpec parentModel parentAction--renderViewSpec :: (ViewSpecContainer parentModel parentAction) => parentModel -> View parentAction-renderViewSpec container = renderFunc container- where- (ViewSpec (renderFunc,_)) = getViewSpec container--type WrappedRun parentModel parentAction =- RoutingURI -> parentModel -> Maybe (Effect parentAction parentModel)--type WrappedUpdate parentModel parentAction = parentModel -> parentAction -> Effect parentAction parentModel--data RoutingTable parentModel parentAction =- RoutingTable [(WrappedRun parentModel parentAction, WrappedUpdate parentModel parentAction)]--newRoutingTable :: RoutingTable parentModel parentAction-newRoutingTable = RoutingTable []--addRoute :: (RouteConvert parentModel parentAction model action) =>- Proxy model -> RoutingTable parentModel parentAction -> RoutingTable parentModel parentAction-addRoute pxy (RoutingTable table) =- RoutingTable $ (wrappedRunRoute pxy, wrappedRouteUpdate pxy):table--runTable :: (ViewSpecContainer parentModel parentAction) =>- RoutingTable parentModel parentAction ->- (parentModel -> View parentAction) ->- RoutingURI ->- parentModel ->- Effect parentAction parentModel-runTable (RoutingTable routes) notFoundView routingURI parentModel =- case safeHead $ catMaybes routeRunResults of- Nothing -> (noEff $ setViewSpec parentModel (ViewSpec (notFoundView, routingURI)))- Just results -> results- where- routeRunResults = map (\run -> run routingURI parentModel) $ map fst routes--updateTable ::- RoutingTable parentModel parentAction ->- parentModel ->- parentAction ->- Effect parentAction parentModel-updateTable (RoutingTable tbl) initialParentModel parentAction =- foldr doMerge initialEffect updateCalls- where- initialEffect = Effect initialParentModel []- updateCalls = map snd tbl- doMerge call (Effect parentModel ios) =- let (Effect newParentModel moreIOs) = call parentModel parentAction in- Effect newParentModel (ios++moreIOs)--
src/RFC/Miso/String.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-dodgy-exports #-}@@ -11,48 +14,73 @@ , module Miso.String ) where -import Data.Function (id, (.))-import Data.String (String)-import Data.String.Conversions-import Miso.String (MisoString, ToMisoString (..))-import Miso.Subscription.History (URI (..))-import RFC.Data.UUID as UUID-import Text.Show+import Data.String ()+import Miso.String (MisoString, ToMisoString (..))+import RFC.Data.UUID ()+import RFC.String () +#ifdef GHCJS+import Data.MonoTraversable+import qualified Data.Text.Lazy as TL+import RFC.Prelude -instance {-# OVERLAPPING #-} ConvertibleStrings URI MisoString where- convertString = toMisoString . show+type instance Element MisoString = Char -instance {-# OVERLAPPING #-} ConvertibleStrings URI URI where- convertString = id+instance MonoFunctor MisoString where+ omap :: (Char -> Char) -> MisoString -> MisoString+ omap f = toMisoString . omap f . toLazyText+ {-# INLINE omap #-} -instance {-# OVERLAPPABLE #-} (ConvertibleStrings String a) => ConvertibleStrings URI a where- {-# SPECIALIZE instance ConvertibleStrings URI String #-}- {-# SPECIALIZE instance ConvertibleStrings URI LazyText #-}- {-# SPECIALIZE instance ConvertibleStrings URI StrictText #-}- {-# SPECIALIZE instance ConvertibleStrings URI LazyByteString #-}- {-# SPECIALIZE instance ConvertibleStrings URI StrictByteString #-}- convertString = convertString . show+instance MonoFoldable MisoString where+ ofoldMap f = ofoldr (mappend . f) mempty+ {-# INLINABLE ofoldMap #-} -instance {-# OVERLAPPING #-} ConvertibleStrings UUID.UUID MisoString where- convertString = toMisoString . UUID.toString+ ofoldr :: (Char -> a -> a) -> a -> MisoString -> a+ ofoldr f init str = TL.foldr f init $ toLazyText str+ {-# INLINE ofoldr #-} -instance {-# OVERLAPPING #-} ConvertibleStrings MisoString MisoString where- convertString = id+ ofoldl' :: (a -> Char -> a) -> a -> MisoString -> a+ ofoldl' f init str = TL.foldl' f init $ toLazyText str+ {-# INLINE ofoldl' #-} -instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings MisoString str where- {-# SPECIALIZE instance ConvertibleStrings MisoString String #-}- {-# SPECIALIZE instance ConvertibleStrings MisoString LazyText #-}- {-# SPECIALIZE instance ConvertibleStrings MisoString StrictText #-}- {-# SPECIALIZE instance ConvertibleStrings MisoString LazyByteString #-}- {-# SPECIALIZE instance ConvertibleStrings MisoString StrictByteString #-}- convertString = fromMisoString+ otoList = ofoldr (:) []+ {-# INLINABLE otoList #-} -instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings str MisoString where- {-# SPECIALIZE instance ConvertibleStrings String MisoString #-}- {-# SPECIALIZE instance ConvertibleStrings LazyText MisoString #-}- {-# SPECIALIZE instance ConvertibleStrings StrictText MisoString #-}- {-# SPECIALIZE instance ConvertibleStrings LazyByteString MisoString #-}- {-# SPECIALIZE instance ConvertibleStrings StrictByteString MisoString #-}- convertString = toMisoString+ oall f str = TL.all f $ toLazyText str+ {-# INLINE oall #-} + oany :: (Char -> Bool) -> MisoString -> Bool+ oany f str = TL.any f $ toLazyText str+ {-# INLINE oany #-}++ onull = TL.null . toLazyText+ {-# INLINE onull #-}++ olength64 = TL.length . toLazyText+ {-# INLINE olength64 #-}++ ofoldr1Ex :: (Char -> Char -> Char) -> MisoString -> Char+ ofoldr1Ex f str = TL.foldr1 f $ toLazyText str+ {-# INLINE ofoldr1Ex #-}++ ofoldl1Ex' :: (Char -> Char -> Char) -> MisoString -> Char+ ofoldl1Ex' f str = TL.foldl1' f $ toLazyText str+ {-# INLINE ofoldl1Ex' #-}++ headEx = TL.head . toLazyText+ {-# INLINE headEx #-}++ lastEx = TL.last . toLazyText+ {-# INLINE lastEx #-}++instance {-# OVERLAPPING #-} FromText MisoString where+ fromText :: Text -> MisoString+ fromText = toMisoString+ {-# INLINE fromText #-}++instance {-# OVERLAPPING #-} ToText MisoString where+ toText :: MisoString -> Text+ toText = fromMisoString+ {-# INLINE toText #-}++#endif
− src/RFC/Miso/XHR.hs
@@ -1,7 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}--module RFC.Miso.XHR- ( module RFC.Miso.XHR- ) where--import RFC.Prelude ()
src/RFC/Prelude.hs view
@@ -1,7 +1,13 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ module RFC.Prelude ( module RFC.Prelude , module RFC.Data.UUID- , module Data.String.Conversions , module GHC.Generics , module Text.Read , module Data.Time.Units@@ -14,48 +20,107 @@ , module Data.Default , module ClassyPrelude , module Control.Monad.Trans.Control- , module UnliftIO.Exception- , module Control.Monad.IO.Unlift , module RFC.String , module Data.Word+ , module Data.Semigroup+ , module Control.Monad.Fail+ , module Data.Time.Clock+ , module UnliftIO+ , module GHC.Exts+ , module Control.Lens.Lens+ , module Control.Lens.Prism+ , module Control.Lens.Type+ , module Data.Proxy ) where -import ClassyPrelude hiding (Day, unpack)-import Control.Monad (forever, void, (<=<), (>=>))-import Control.Monad.IO.Unlift+import ClassyPrelude hiding ( Day, fail, fromList, toList, unpack )+import Control.Lens.Lens+import Control.Lens.Prism+import Control.Lens.Type+import Control.Monad ( forever, void, (<=<), (>=>) )+import Control.Monad.Fail ( MonadFail, fail ) import Control.Monad.Trans.Control import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.Char as Char import Data.Default-import Data.Function ((&))+import qualified Data.Foldable as Foldable+import Data.Function ( (&) ) import qualified Data.List as List-import Data.String.Conversions (LazyByteString, LazyText,- StrictByteString, StrictText, cs)+import Data.Proxy ( Proxy (..) )+import Data.Semigroup+import Data.Time.Clock import Data.Time.Units-import Data.Typeable (TypeRep, typeOf)-import Data.Word (Word16)-import GHC.Generics (Generic)-import RFC.Data.UUID (UUID)+import Data.Typeable ( TypeRep, typeOf )+import Data.Word ( Word16 )+import GHC.Conc.Sync+import GHC.Generics ( Generic )+import RFC.Data.UUID ( UUID ) import RFC.String-import Text.Read (Read, read)-import UnliftIO.Exception+import Text.Read ( Read, read )+import UnliftIO+#ifdef VERSION_exceptions+import Control.Monad.Catch+#endif+import GHC.Exts ( IsList (..), fromListN ) +ifThenElse :: Bool -> a -> a -> a+ifThenElse test true false =+ case test of+ True -> true+ False -> false+{-# INLINE ifThenElse #-}+ charIsUpper :: Char -> Bool charIsUpper = Char.isUpper+{-# INLINE charIsUpper #-} charIsLower :: Char -> Bool charIsLower = Char.isLower+{-# INLINE charIsLower #-} uniq :: (Eq a) => [a] -> [a] uniq = List.nub+{-# INLINE uniq #-} -safeHead :: [a] -> Maybe a-safeHead [] = Nothing-safeHead (x:_) = Just x+safeHead :: (MonadFail m, Foldable f) => f a -> m a+safeHead xs =+ case Foldable.toList xs of+ [] -> fail "Attempted to head an empty list"+ (x:_) -> return x+{-# INLINE safeHead #-}+{-# SPECIALIZE INLINE safeHead :: [a] -> Maybe a #-}+{-# SPECIALIZE INLINE safeHead :: [a] -> IO a #-} foldl :: MonoFoldable mono => (a -> Element mono -> a) -> a -> mono -> a foldl = foldl'+{-# INLINE foldl #-} type Boolean = Bool -- I keep forgetting which Haskell uses....++newtype Failed = Failed String+ deriving (Show, Eq, Ord, Generic, Typeable)+instance Exception Failed++instance {-# OVERLAPPABLE #-} (Monad m, MonadIO m) => MonadFail m where+ fail = throwIO . Failed+ {-# INLINE fail #-}++#ifdef VERSION_exceptions+instance {-# OVERLAPPABLE #-} MonadThrow m => MonadFail m where+ fail = throwM . Failed+ {-# INLINE fail #-}+#endif++instance {-# OVERLAPPING #-} MonadFail STM where+ fail _ = retry+ {-# INLINE fail #-}++instance {-# OVERLAPPING #-} MonadFail (Either String) where+ fail = Left+ {-# INLINE fail #-}++instance {-# OVERLAPPING #-} MonadFail Option where+ fail _ = Option Nothing+ {-# INLINE fail #-}
src/RFC/Psql.hs view
@@ -1,105 +1,104 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module RFC.Psql- ( module Database.PostgreSQL.Simple- , module Database.PostgreSQL.Simple.FromField- , module Database.PostgreSQL.Simple.FromRow- , module Database.PostgreSQL.Simple.ToField- , module Database.PostgreSQL.Simple.ToRow- , module Database.PostgreSQL.Simple.SqlQQ- , module Database.PostgreSQL.Simple.Types+ ( module Database.PostgreSQL.Typed+ , module Database.PostgreSQL.Typed.Query+ , module Database.PostgreSQL.Typed.Types , module RFC.Psql ) where -import Control.Monad.Trans.Control import Data.Pool-import Database.PostgreSQL.Simple (ConnectInfo, Connection,- FromRow, In (..),- Only (..), Query, commit,- connectDatabase,- connectPassword,- connectUser)-import qualified Database.PostgreSQL.Simple as Psql-import Database.PostgreSQL.Simple.FromField hiding (Binary)-import Database.PostgreSQL.Simple.FromRow-import Database.PostgreSQL.Simple.SqlQQ-import Database.PostgreSQL.Simple.ToField-import Database.PostgreSQL.Simple.ToRow-import Database.PostgreSQL.Simple.Types-import RFC.Env-import RFC.Log+import Database.PostgreSQL.Typed+import Database.PostgreSQL.Typed.Query+import Database.PostgreSQL.Typed.Types+import qualified RFC.Env as Env import RFC.Prelude -type ConnectionPool = Pool Connection+type PGConnectionPool = Pool PGConnection+type ConnectionPool = PGConnectionPool -class (MonadIO m, MonadBaseControl IO m) => HasPsql m where- getPsqlPool :: m ConnectionPool+class HasPsql m where+ getPsqlPool :: m PGConnectionPool - withPsqlConnection :: (Connection -> m a) -> m a- withPsqlConnection action = do- pool <- getPsqlPool- withResource pool action+instance {-# OVERLAPS #-} (Monad m) => HasPsql (ReaderT PGConnectionPool m) where+ getPsqlPool = ask+ {-# INLINE getPsqlPool #-} - withPsqlTransaction :: (Connection -> m a) -> m a- withPsqlTransaction action = withPsqlConnection $ \conn ->- (liftBaseOp_ (Psql.withTransaction conn)) (action conn)+withPsqlConnection :: (HasPsql m, MonadIO m) => (PGConnection -> IO a) -> m a+withPsqlConnection action = do+ pool <- getPsqlPool+ liftIO $ withResource pool action+{-# INLINE withPsqlConnection #-} -defaultConnectInfo :: (MonadIO m) => m ConnectInfo-defaultConnectInfo = RFC.Env.readPsqlConnectInfo+withPsqlTransaction :: (HasPsql m, MonadIO m) => IO a -> m a+withPsqlTransaction action = withPsqlConnection $ \conn -> do+ let newMonad = ReaderT (const action)+ liftIO $ pgTransaction conn $ runReaderT newMonad conn+{-# INLINABLE withPsqlTransaction #-} -createConnectionPool :: (MonadIO m) => ConnectInfo -> m ConnectionPool-createConnectionPool connInfo = liftIO $- createPool connect close 1 10 100- where- connect = do- logDebug "Opening DB connection"- Psql.connect connInfo- close conn = do- logDebug "Closing DB connection"- Psql.close conn+instance {-# OVERLAPPING #-} Env.DefConfig PGDatabase where+ defConfig = defaultPGDatabase+ {-# INLINE defConfig #-} -query :: (MonadIO m, FromRow r, ToRow q) => Connection -> Query -> q -> m [r]-query conn qry q = liftIO $ Psql.query conn qry q+instance Env.FromEnv PGDatabase where+ fromEnv = PGDatabase <$> Env.env "PSQL_HOST"+ <*> Env.env "PSQL_PORT"+ <*> Env.env "PSQL_DATABASE"+ <*> Env.env "PSQL_USERNAME"+ <*> Env.env "PSQL_PASSWORD"+ <*> pure []+ <*> pure Env.isDevelopment+ <*> pure (+ if Env.isDevelopment then+ print . PGError+ else+ const $ return ()+ )+ {-# INLINE fromEnv #-} -query_ :: (MonadIO m, FromRow r) => Connection -> Query -> m [r]-query_ conn qry = liftIO $ Psql.query_ conn qry -query1 :: (MonadIO m, FromRow r, ToRow q) => Connection -> Query -> q -> m (Maybe r)-query1 conn qry q = do- result <- query conn qry q- return $ case result of- [] -> Nothing- (r:_) -> Just r+defaultConnectInfo :: (MonadIO m, MonadFail m) => m PGDatabase+defaultConnectInfo = do+ result <- liftIO $ Env.decodeEnv+ case result of+ Left err -> fail $ "Could not retrieve psql connection info: " ++ err+ Right connInfo -> return connInfo+{-# INLINE defaultConnectInfo #-} -query1_ :: (MonadIO m, FromRow r) => Connection -> Query -> m (Maybe r)-query1_ conn qry = do- result <- query_ conn qry- return $ case result of- [] -> Nothing- (r:_) -> Just r+createConnectionPool :: (MonadIO m) => PGDatabase -> m PGConnectionPool+createConnectionPool connInfo = liftIO $+ createPool connect close 1 10 100+ where+ connect = pgConnect connInfo+ close = pgDisconnect+{-# INLINE createConnectionPool #-} -query1Else :: (MonadIO m, FromRow r, ToRow q, Exception e) => Connection -> Query -> q -> e -> m (Maybe r)-query1Else conn qry q e = do- result <- query1 conn qry q- case result of- (Just _) -> return result- Nothing -> liftIO $ throwIO e+query :: (MonadIO m, HasPsql m, PGQuery q a) => q -> m [a]+query q = withPsqlConnection $ \conn -> pgQuery conn q+{-# INLINE query #-} -query1Else_ :: (MonadIO m, FromRow r, Exception e) => Connection -> Query -> e -> m (Maybe r)-query1Else_ conn qry e = do- result <- query1_ conn qry+query1 :: (MonadIO m, HasPsql m, PGQuery q a) => q -> m (Maybe a)+query1 qry = safeHead <$> query qry+{-# INLINE query1 #-}++query1Else :: (MonadIO m, HasPsql m, PGQuery q a, Exception e) => q -> e -> m (Maybe a)+query1Else qry e = do+ result <- query1 qry case result of (Just _) -> return result- Nothing -> liftIO $ throwIO e--execute :: (MonadIO m, ToRow q) => Connection -> Query -> q -> m Int64-execute conn qry q = liftIO $ Psql.execute conn qry q+ Nothing -> throwIO e+{-# INLINE query1Else #-} -execute_ :: (MonadIO m) => Connection -> Query -> m Int64-execute_ conn qry = liftIO $ Psql.execute_ conn qry+execute :: (MonadIO m, HasPsql m, PGQuery q ()) => q -> m Int+execute q = withPsqlConnection $ \conn -> pgExecute conn q+{-# INLINE execute #-} -executeMany :: (MonadIO m, ToRow q) => Connection -> Query -> [q] -> m Int64-executeMany conn qry qs = liftIO $ Psql.executeMany conn qry qs+execute_ :: (MonadIO m, HasPsql m, PGQuery q ()) => q -> m ()+execute_ q = do+ _ <- withPsqlConnection $ \conn -> pgExecute conn q+ return ()+{-# INLINE execute_ #-}
src/RFC/Redis.hs view
@@ -11,10 +11,11 @@ , setex ) where -import qualified Database.Redis as R-import RFC.Env as Env+import Data.Time.Clock (nominalDay)+import qualified Database.Redis as R+import RFC.Env as Env import RFC.Prelude-import RFC.String ()+import RFC.String () type ConnectionPool = R.Connection @@ -28,11 +29,30 @@ runRedis r = do conn <- getRedisPool liftIO $ R.runRedis conn r+ {-# INLINE runRedis #-} -createConnectionPool :: (MonadUnliftIO m) => m ConnectionPool++instance DefConfig R.ConnectInfo where+ defConfig = R.defaultConnectInfo+ {-# INLINE defConfig #-}++instance FromEnv R.ConnectInfo where+ fromEnv = R.ConnInfo+ <$> (envWithDevDefault "REDIS_HOST" $ R.connectHost defConfig)+ <*> (envWithDefault "REDIS_PORT" $ R.connectPort defConfig)+ <*> (envWithDefault "REDIS_AUTH" $ R.connectAuth defConfig)+ <*> (envWithDefault "REDIS_DB" $ R.connectDatabase defConfig)+ <*> (envWithDefault "REDIS_MAX_CONNS" $ R.connectMaxConnections defConfig)+ <*> (envWithDefault "REDIS_IDLE_TIMEOUT" $ R.connectMaxIdleTime defConfig)+ <*> (envWithDefault "REDIS_CONN_TIMEOUT" $ Just (nominalDay/24)) -- No timeout by default!+ {-# INLINABLE fromEnv #-}++createConnectionPool :: (MonadUnliftIO m, MonadFail m) => m ConnectionPool createConnectionPool = do- connInfo <- Env.readRedisConnectInfo- liftIO $ R.connect connInfo+ connInfoResult <- liftIO decodeEnv+ case connInfoResult of+ Left err -> fail $ "Could not configure Redis connection: " ++ err+ Right connInfo -> liftIO $ R.connect connInfo get :: (HasRedis m, ConvertibleToSBS tIn, ConvertibleFromSBS tOut) => tIn -> m (Maybe tOut) get key = do
src/RFC/Servant.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -24,23 +25,22 @@ , module RFC.API ) where -import Control.Natural (type (~>))-import Data.Aeson as JSON-import qualified Data.Aeson.Diff as JSON-import Data.Swagger (Swagger, ToSchema)-import Database.PostgreSQL.Simple (SqlError (..))-import Network.Wreq.Session as Wreq+import Control.Natural (type (~>))+import Data.Aeson as JSON+import qualified Data.Aeson.Diff as JSON+import Data.Swagger (Swagger, ToSchema)+import Network.Wreq.Session as Wreq import RFC.API import RFC.Data.IdAnd import RFC.HTTP.Client-import RFC.JSON ()-import RFC.Prelude hiding (Handler)-import qualified RFC.Psql as Psql-import qualified RFC.Redis as Redis+import RFC.JSON ()+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 Servant.Docs hiding (API)+import Servant.HTML.Blaze (HTML)+import Servant.Server (Handler, runHandler) import Text.Blaze.Html type ApiCtx =@@ -51,22 +51,26 @@ ) ) -instance {-# OVERLAPPABLE #-} MonadUnliftIO Handler where+instance {-# OVERLAPPING #-} MonadUnliftIO Handler where askUnliftIO = return $ UnliftIO $ \handler -> do either <- runHandler handler case either of Left err -> throwIO err Right v -> return v+ {-# INLINE askUnliftIO #-} instance HasAPIClient ApiCtx where getAPIClient = ask+ {-# INLINE getAPIClient #-} instance Psql.HasPsql ApiCtx where getPsqlPool = lift ask+ {-# INLINE getPsqlPool #-} instance Redis.HasRedis ApiCtx where getRedisPool = lift $ lift ask+ {-# INLINE getRedisPool #-} apiCtxToHandler :: Wreq.Session -> Redis.ConnectionPool -> Psql.ConnectionPool -> ApiCtx ~> Handler apiCtxToHandler apiClient redisPool psqlPool = toHandler@@ -77,6 +81,7 @@ withAPIClient m = runReaderT m apiClient withRedis m = runReaderT m redisPool withPsql m = runReaderT m psqlPool+{-# INLINE apiCtxToHandler #-} type FetchAllImpl a = ApiCtx (RefMap a) type FetchAllAPI a = JGet (RefMap a)@@ -85,7 +90,7 @@ type CreateImpl a = a -> ApiCtx (IdAnd a) type CreateAPI a = JReqBody a :> JPost (IdAnd a) type PatchImpl a = UUID -> JSON.Patch -> ApiCtx (IdAnd a)--- type PatchAPI a = Capture "id" UUID :> ReqBody '[JSON] JSON.Patch :> Patch '[JSON] (IdAnd a)+type PatchAPI a = Capture "id" UUID :> ReqBody '[JSON] JSON.Patch :> Patch '[JSON] (IdAnd a) type ReplaceImpl a = UUID -> a -> ApiCtx (IdAnd a) type ReplaceAPI a = Capture "id" UUID :> JReqBody a :> JPost (IdAnd a) @@ -93,13 +98,13 @@ (FetchAllImpl a) :<|> (FetchImpl a) :<|> (CreateImpl a)- -- :<|> (PatchImpl a)+ :<|> (PatchImpl a) :<|> (ReplaceImpl a) type ServerAPI a = (FetchAllAPI a) :<|> (FetchAPI a) :<|> (CreateAPI a)- -- :<|> (PatchAPI a)+ :<|> (PatchAPI a) :<|> (ReplaceAPI a) @@ -108,6 +113,7 @@ restFetchAll = do resources <- fetchAllResources return $ idAndsToMap resources+ {-# INLINE restFetchAll #-} restFetch :: FetchImpl a restFetch uuid = do@@ -115,65 +121,56 @@ case maybeResource of Nothing -> throwError $ err404 { errReasonPhrase = "No resource found for id"- , errBody = cs $ "Could not find a resource with UUID: " ++ show uuid+ , errBody = asUTF8 $ "Could not find a resource with UUID: " ++ show uuid } Just value -> return $ IdAnd (uuid, value)+ {-# INLINE restFetch #-} restCreate :: CreateImpl a- restCreate a = handleDupes $ do+ restCreate a = do maybeId <- createResource a case maybeId of (Just id) -> restFetch id Nothing -> throwIO $ err400 { errReasonPhrase = "Could not create resource"- , errBody = cs $ show a+ , errBody = asUTF8 $ show a }+ {-# INLINE restCreate #-} restPatch :: PatchImpl a- restPatch id patch = handleDupes $ do+ restPatch id patch = do (IdAnd (_,original::a)) <- restFetch id case JSON.patch patch $ toJSON original of Error str -> throwError $ err400 { errReasonPhrase = "Error applying patch"- , errBody = cs str+ , errBody = asUTF8 str } Success jsonValue -> case JSON.eitherDecode' $ JSON.encode jsonValue of Left err -> throwError $ err400 { errReasonPhrase = "Error rebuilding object after patch"- , errBody = cs err+ , errBody = asUTF8 err } Right value -> restReplace id value+ {-# INLINE restPatch #-} restReplace :: ReplaceImpl a- restReplace id value = handleDupes $ do+ restReplace id value = do replaceResource newValue restFetch id where newValue = IdAnd (id,value)+ {-# INLINE restReplace #-} restServer :: ServerImpl a restServer = restFetchAll :<|> restFetch :<|> restCreate- -- :<|> restPatch+ :<|> restPatch :<|> restReplace fetchResource :: UUID -> ApiCtx (Maybe a) fetchAllResources :: ApiCtx [IdAnd a] createResource :: a -> ApiCtx (Maybe UUID) replaceResource :: (IdAnd a) -> ApiCtx ()--handleDupes :: ApiCtx a -> ApiCtx a-handleDupes =- handleJust isDuplicate throwUp- where- throwUp err = throwIO $ err409- { errReasonPhrase = cs $ sqlErrorMsg err- , errBody = cs $ sqlErrorDetail err- }- isDuplicate (sqle::SqlError)- | sqlState sqle == "23505" = Just sqle- isDuplicate _ = Nothing-
src/RFC/Servant/ApiDoc.hs view
@@ -19,7 +19,6 @@ 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@@ -46,8 +45,8 @@ , MD.msAddHeadingId = True } -apiToAscii :: (ConvertibleString String s, HasDocs a) => Proxy a -> s-apiToAscii = cs . markdown . docs+apiToAscii :: HasDocs a => Proxy a -> String+apiToAscii = markdown . docs apiToSwagger :: (HasSwagger a) => Proxy a -> Swagger apiToSwagger = toSwagger@@ -58,16 +57,13 @@ ("GET", Just doIt) -> doIt _ -> application request callback where+ bsToStr = maybe "" cs . decodeText . UTF8 html = Blaze.renderHtml $ apiToHtml api- ascii :: LazyByteString ascii = apiToAscii api- swaggerToLbs :: Swagger -> LazyByteString swaggerToLbs = Builder.toLazyByteString . fromEncoding . toEncoding swagger = swaggerToLbs $ apiToSwagger api <> addlSwagger- reqMethod :: String- reqMethod = map Char.toUpper $ cs $ requestMethod request- pathInfo :: String- pathInfo = map Char.toLower $ cs $ rawPathInfo request+ reqMethod = map charToUpper $ bsToStr $ requestMethod request+ pathInfo = map charToLower $ bsToStr $ rawPathInfo request reqPath = case pathInfo of "swagger.json" -> Just serveSwagger@@ -77,14 +73,11 @@ "api.txt" -> Just serveTxt "/api.txt" -> Just serveTxt _ -> Nothing- response ::- (ConvertibleStrings contentType StrictByteString, ConvertibleStrings body LazyByteString) =>- contentType -> body -> IO ResponseReceived response contentType body = callback $- responseLBS status200 [(hContentType, cs contentType)] (cs body)- serveHtml = response "text/html" html- serveTxt = response "text/plain" ascii- serveSwagger = response "application/json" swagger+ responseLBS status200 [(hContentType, contentType)] body+ serveHtml = response (cs $ UTF8 "text/html") (cs $ UTF8 html)+ serveTxt = response (cs $ UTF8 "text/plain") (cs $ UTF8 ascii)+ serveSwagger = response (cs $ UTF8 "application/json") swagger instance ToSample () where
src/RFC/String.hs view
@@ -1,29 +1,213 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} module RFC.String ( module RFC.String- , module Data.String.Conversions- , module Data.String.Conversions.Monomorphic+ , module Data.Text.Conversions ) where -import Data.String (String)-import Data.String.Conversions hiding ((<>))-import Data.String.Conversions.Monomorphic hiding (fromString,- toString)+import ClassyPrelude hiding (fail)+import Control.Monad.Fail (MonadFail, fail)+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import Data.String (String)+import qualified Data.Text as ST+import Data.Text.Conversions+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LTBuilder+import Network.URI (URI (..), parseURIReference,+ uriToString)+ #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-type ConvertibleFromSBS a = ConvertibleStrings StrictByteString a-type ConvertibleToString a = ConvertibleStrings a String+type LazyText = LT.Text+type StrictText = ST.Text+type LazyByteString = LB.ByteString+type StrictByteString = SB.ByteString++type ConvertibleString = ConvertibleStrings+type ConvertibleToSBS a = ConvertibleStrings a StrictByteString+type ConvertibleFromSBS a = ConvertibleStrings StrictByteString a+type ConvertibleToString a = ConvertibleStrings a String type ConvertibleFromString a = ConvertibleStrings String a +toStrictText :: (ToText a) => a -> StrictText+toStrictText = toText+{-# SPECIALIZE INLINE toStrictText :: String -> StrictText #-}+{-# SPECIALIZE INLINE toStrictText :: LazyText -> StrictText #-}+{-# SPECIALIZE INLINE toStrictText :: StrictText -> StrictText #-}++toLazyText :: (ToText a) => a -> LazyText+toLazyText = LT.fromStrict . toText+{-# INLINE toLazyText #-}+{-# SPECIALIZE INLINE toLazyText :: String -> LazyText #-}+{-# SPECIALIZE INLINE toLazyText :: StrictText -> LazyText #-}+{-# SPECIALIZE INLINE toLazyText :: LazyText -> LazyText #-}++asUTF8 :: (ToText a, FromText (UTF8 b)) => a -> b+asUTF8 it = unUTF8 $ fromText $ toText it+{-# INLINE asUTF8 #-}+{-# SPECIALIZE INLINE asUTF8 :: String-> LazyByteString #-}+{-# SPECIALIZE INLINE asUTF8 :: StrictText -> LazyByteString #-}+{-# SPECIALIZE INLINE asUTF8 :: LazyText -> LazyByteString #-}+{-# SPECIALIZE INLINE asUTF8 :: String-> StrictByteString #-}+{-# SPECIALIZE INLINE asUTF8 :: StrictText -> StrictByteString #-}+{-# SPECIALIZE INLINE asUTF8 :: LazyText -> StrictByteString #-}++toUTF8 :: (DecodeText f (UTF8 a), FromText b) => a -> f b+toUTF8 it = decodeConvertText (UTF8 it)+{-# INLINE toUTF8 #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyByteString -> Maybe String #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyByteString -> Maybe StrictText #-}+{-# SPECIALIZE INLINE toUTF8 :: LazyByteString -> Maybe LazyText #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictByteString -> Maybe String #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictByteString -> Maybe StrictText #-}+{-# SPECIALIZE INLINE toUTF8 :: StrictByteString -> Maybe LazyText #-}++instance {-# OVERLAPPABLE #-} (Show a, DecodeText Maybe a, MonadFail m) => DecodeText m a where+ {-# SPECIALIZE instance DecodeText IO (UTF8 LazyByteString) #-}+ {-# SPECIALIZE instance DecodeText IO (UTF8 StrictByteString) #-}+ {-# SPECIALIZE instance DecodeText [] (UTF8 LazyByteString) #-}+ {-# SPECIALIZE instance DecodeText [] (UTF8 StrictByteString) #-}+ {-# SPECIALIZE instance DecodeText Maybe (UTF8 LazyByteString) #-}+ {-# SPECIALIZE instance DecodeText Maybe (UTF8 StrictByteString) #-}+ decodeText a =+ case decodeText a of+ [] ->+ fail $ "Could not decode text: " ++ (show a)+ x:_ ->+ return x++emptyString :: (FromText a) => a+emptyString = fromText $ toText ""+{-# INLINE emptyString #-}+{-# SPECIALIZE INLINE emptyString :: String #-}+{-# SPECIALIZE INLINE emptyString :: LazyText #-}+{-# SPECIALIZE INLINE emptyString :: StrictText #-}++emptyUTF8 :: (FromText (UTF8 a)) => a+emptyUTF8 = unUTF8 $ fromText $ toText ""+{-# INLINE emptyUTF8 #-}++instance {-# OVERLAPPING #-} ToText Char where+ toText c = toText [c]+ {-# INLINE toText #-}++instance {-# OVERLAPPABLE #-} (FromText a) => FromText (UTF8 a) where+ {-# SPECIALISE instance FromText (UTF8 StrictText) #-}+ {-# SPECIALISE instance FromText (UTF8 LazyText) #-}+ {-# SPECIALISE instance FromText (UTF8 String) #-}+ fromText = UTF8 . fromText+ {-# INLINE fromText #-}++instance {-# OVERLAPPABLE #-} (ToText a) => ToText (UTF8 a) where+ {-# SPECIALISE instance ToText (UTF8 StrictText) #-}+ {-# SPECIALISE instance ToText (UTF8 LazyText) #-}+ {-# SPECIALISE instance ToText (UTF8 String) #-}+ toText = toText . unUTF8+ {-# INLINE toText #-}++instance {-# OVERLAPPING #-} ToText URI where+ toText uri = toText $ uriToString id uri ""+ {-# INLINE toText #-}++instance {-# OVERLAPS #-} (MonadFail f) => FromText (f URI) where+ {-# SPECIALIZE instance FromText (Maybe URI) #-}+ {-# SPECIALIZE instance FromText (IO URI) #-}+ fromText txt =+ case parseURIReference (fromText txt) of+ Nothing -> fail $ "Could not parse URI: " ++ (cs txt)+ Just uri -> return uri+ {-# INLINE fromText #-}++class ConvertibleStrings a b where+ cs :: a -> b++instance {-# OVERLAPPING #-} ConvertibleStrings LazyByteString StrictByteString where+ cs = LB.toStrict+ {-# INLINE cs #-}++instance {-# OVERLAPPING #-} ConvertibleStrings StrictByteString LazyByteString where+ cs = LB.fromStrict+ {-# INLINE cs #-}++instance {-# OVERLAPPABLE #-} (DecodeText f a, FromText b) => ConvertibleStrings a (f b) where+ cs = decodeConvertText+ {-# INLINE cs #-}++instance {-# OVERLAPS #-} (ToText (UTF8 a), FromText b) => ConvertibleStrings a (UTF8 b) where+ cs a = UTF8 $ fromText $ toText $ UTF8 a+ {-# INLINE cs #-}++instance {-# OVERLAPS #-} (ToText a, FromText (UTF8 b)) => ConvertibleStrings (UTF8 a) b where+ {-# SPECIALISE instance ConvertibleStrings (UTF8 StrictText) LazyByteString #-}+ {-# SPECIALISE instance ConvertibleStrings (UTF8 LazyText) LazyByteString #-}+ {-# SPECIALISE instance ConvertibleStrings (UTF8 String) LazyByteString #-}+ {-# SPECIALISE instance ConvertibleStrings (UTF8 StrictText) StrictByteString #-}+ {-# SPECIALISE instance ConvertibleStrings (UTF8 LazyText) StrictByteString #-}+ {-# SPECIALISE instance ConvertibleStrings (UTF8 String) StrictByteString #-}+ cs (UTF8 it) = unUTF8 $ fromText $ toText it+ {-# INLINE cs #-}++instance {-# OVERLAPS #-} (ToText a, FromText b) => ConvertibleStrings a b where+ {-# SPECIALIZE instance ConvertibleStrings String LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings String StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText String #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings StrictText LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings StrictText (Maybe (Base64 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText (Maybe (Base64 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings String (Maybe (Base64 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings StrictText (Maybe (Base16 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText (Maybe (Base16 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings String (Maybe (Base16 StrictByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 StrictByteString) String #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 StrictByteString) StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 StrictByteString) LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 StrictByteString) String #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 StrictByteString) StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 StrictByteString) LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 LazyByteString) String #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 LazyByteString) StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base16 LazyByteString) LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 LazyByteString) String #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 LazyByteString) StrictText #-}+ {-# SPECIALIZE instance ConvertibleStrings (Base64 LazyByteString) LazyText #-}+ {-# SPECIALIZE instance ConvertibleStrings StrictText (Maybe (Base64 LazyByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText (Maybe (Base64 LazyByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings String (Maybe (Base64 LazyByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings StrictText (Maybe (Base16 LazyByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings LazyText (Maybe (Base16 LazyByteString)) #-}+ {-# SPECIALIZE instance ConvertibleStrings String (Maybe (Base16 LazyByteString)) #-}+ {-# SPECIALISE instance ConvertibleStrings StrictText (UTF8 LazyByteString) #-}+ {-# SPECIALISE instance ConvertibleStrings LazyText (UTF8 LazyByteString) #-}+ {-# SPECIALISE instance ConvertibleStrings String (UTF8 LazyByteString) #-}+ {-# SPECIALISE instance ConvertibleStrings StrictText (UTF8 StrictByteString) #-}+ {-# SPECIALISE instance ConvertibleStrings LazyText (UTF8 StrictByteString) #-}+ {-# SPECIALISE instance ConvertibleStrings String (UTF8 StrictByteString) #-}+ cs :: a -> b+ cs = fromText . toText+ {-# INLINE cs #-}++instance {-# OVERLAPPING #-} ConvertibleStrings StrictText String where+ cs :: StrictText -> String+ cs = ST.unpack+ {-# INLINE cs #-}++instance {-# OVERLAPS #-} ConvertibleStrings a a where+ cs :: a -> a+ cs = id+ {-# INLINE cs #-}+ #ifndef GHCJS_BROWSER instance ToSample StrictText where@@ -33,3 +217,10 @@ toSamples _ = singleSample $ cs "This is random text" #endif++type LazyTextBuilder = LTBuilder.Builder++instance {-# OVERLAPPING #-} ToText LazyTextBuilder where+ toText = cs . LTBuilder.toLazyText+ {-# INLINE toText #-}+
src/RFC/Throttle.hs view
@@ -30,6 +30,8 @@ log2 x | (toInteger x) <= 2 = 1 | otherwise = 1 + log2 (x `quot` 2)+{-# INLINABLE createThrottle #-} withThrottle :: (MonadBaseControl IO m) => Throttle -> m b -> m b withThrottle (Throttle pool) action = withResource pool (const action)+{-# INLINE withThrottle #-}
src/RFC/Wai.hs view
@@ -1,14 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} module RFC.Wai- ( defaultMiddleware+ ( runApplication+ , defaultMiddleware , module Network.Wai ) where import Control.Logger.Simple+import Control.Monad.State.Lazy hiding (fail, mapM_)+import Network import Network.HTTP.Types.Header import Network.HTTP.Types.Method+import Network.Socket import Network.Wai+import Network.Wai.Cli hiding (socket)+import Network.Wai.Handler.Warp import Network.Wai.Middleware.AcceptOverride import Network.Wai.Middleware.Approot (envFallback) import Network.Wai.Middleware.Autohead@@ -18,13 +24,60 @@ import Network.Wai.Middleware.MethodOverridePost import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)-import RFC.Env (isDevelopment)+import RFC.Env (FromEnv (..),+ decodeEnv, envMaybe,+ isDevelopment,+ showEnv, (.!=)) import RFC.Prelude import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) +runApplication :: Application -> IO ()+runApplication app = withSocketsDo $ do+ showEnv+ middlewares <- defaultMiddleware+ warpSettingsResult <- decodeEnv+ case warpSettingsResult of+ Left err -> fail err+ Right warpSettings -> do+ reuseSocket <- bindSocketReusePort $ getPort warpSettings+ runGraceful+ ServeNormally+ (flip runSettingsSocket $ reuseSocket)+ warpSettings+ (middlewares app)+{-# INLINE runApplication #-}++bindSocketReusePort :: Port -> IO Socket+bindSocketReusePort p =+ bracketOnError (socket AF_INET Stream defaultProtocol) close $ \sock -> do+ mapM_ (uncurry $ setSocketOption sock) $ filter (isSupportedSocketOption . fst)+ [ (NoDelay , 1)+ , (KeepAlive, 1)+ , (ReuseAddr, 1)+ , (ReusePort, 1) -- <-- Here we add the SO_REUSEPORT flag.+ ]+ bind sock $ SockAddrInet (fromIntegral p) iNADDR_ANY+ listen sock (max 2048 maxListenQueue)+ return sock++instance FromEnv Settings where+ fromEnv = do+ portNumber <- envMaybe "PORT" .!= 3000+ return+ $ setPort portNumber+ $ setOnExceptionResponse+ (if isDevelopment then+ exceptionResponseForDebug+ else+ -- TODO Render a JSON error response+ defaultOnExceptionResponse+ )+ $ setServerName emptyUTF8+ $ defaultSettings++ defaultMiddleware :: IO Middleware defaultMiddleware = do- isDev <- isDevelopment approot <- envFallback tmpDir <- getTmpDir gzipDir <- mkGzipDir tmpDir@@ -38,6 +91,7 @@ gzip (gzipConfig gzipDir) . (if isDev then logStdoutDev else logStdout) where+ isDev = isDevelopment handleError msg e = do logError . cs $ "Error while: " ++ msg logError . cs . show $ e@@ -63,3 +117,4 @@ { gzipFiles = GzipCacheFolder gzipDir , gzipCheckMime = const True }+{-# INLINABLE defaultMiddleware #-}