diff --git a/rfc.cabal b/rfc.cabal --- a/rfc.cabal +++ b/rfc.cabal @@ -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 diff --git a/src/RFC/API.hs b/src/RFC/API.hs --- a/src/RFC/API.hs +++ b/src/RFC/API.hs @@ -3,7 +3,12 @@ {-# LANGUAGE TemplateHaskell #-} module RFC.API - ( module RFC.API + ( JDelete + , JGet + , JPatch + , JPost + , JPut + , JReqBody ) where import RFC.Prelude () diff --git a/src/RFC/Client/Coinhive.hs b/src/RFC/Client/Coinhive.hs deleted file mode 100644 --- a/src/RFC/Client/Coinhive.hs +++ /dev/null @@ -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 diff --git a/src/RFC/Concurrent.hs b/src/RFC/Concurrent.hs --- a/src/RFC/Concurrent.hs +++ b/src/RFC/Concurrent.hs @@ -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] #-} diff --git a/src/RFC/Data/IdAnd.hs b/src/RFC/Data/IdAnd.hs --- a/src/RFC/Data/IdAnd.hs +++ b/src/RFC/Data/IdAnd.hs @@ -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) diff --git a/src/RFC/Data/LatLng.hs b/src/RFC/Data/LatLng.hs --- a/src/RFC/Data/LatLng.hs +++ b/src/RFC/Data/LatLng.hs @@ -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 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 @@ -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 ( 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 @@ -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 #-} diff --git a/src/RFC/Env.hs b/src/RFC/Env.hs --- a/src/RFC/Env.hs +++ b/src/RFC/Env.hs @@ -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 #-} diff --git a/src/RFC/GHCJS.hs b/src/RFC/GHCJS.hs new file mode 100644 --- /dev/null +++ b/src/RFC/GHCJS.hs @@ -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 diff --git a/src/RFC/GHCJS/Cookie.hs b/src/RFC/GHCJS/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/RFC/GHCJS/Cookie.hs @@ -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 diff --git a/src/RFC/GHCJS/Inject.hs b/src/RFC/GHCJS/Inject.hs new file mode 100644 --- /dev/null +++ b/src/RFC/GHCJS/Inject.hs @@ -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