diff --git a/rfc.cabal b/rfc.cabal --- a/rfc.cabal +++ b/rfc.cabal @@ -1,5 +1,5 @@ name: rfc -version: 0.0.0.17 +version: 0.0.0.18 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,22 +13,22 @@ extra-source-files: README.md cabal-version: >=1.10 -Flag Development - Description: Enable warnings - Default: False - Manual: True - Flag Browser Description: Build assuming GHCJS for the browser. Default: False - Manual: True + Manual: False +Flag Development + Description: Turn on errors for warnings + Default: False + Manual: True + library hs-source-dirs: src build-depends: base >= 4.7 && < 5 default-language: Haskell2010 default-extensions: NoImplicitPrelude - ghc-options: -Wall -fno-warn-orphans -fno-warn-name-shadowing + ghc-options: -Wall -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-tabs if flag(Development) ghc-options: -Werror build-depends: base >= 4.7 && < 5 @@ -48,7 +48,7 @@ , lens , http-types , exceptions - , http-api-data + , http-api-data >= 0.3.7.1 , time-units , aeson-diff , vector @@ -58,9 +58,10 @@ if flag(Browser) build-depends: aeson , attoparsec + , miso >= 0.12.0.0 if !flag(Browser) build-depends: servant-server - , wai + , wai >= 3.2.1.1 , aeson >= 1.2.3.0 , wai-extra , wai-cors @@ -69,8 +70,9 @@ , simple-logger , servant-docs , temporary + , http-client , http-client-tls - , wreq + , wreq >= 0.5.2.0 , servant-swagger , swagger2 , binary @@ -88,15 +90,17 @@ , 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 if !flag(Browser) exposed-modules: RFC.Psql , RFC.Redis , RFC.Log , RFC.Wai , RFC.Env - , RFC.Google.Places.NearbySearch - , RFC.Google.Places.PlaceSearch - , RFC.Google.Places.SearchResults , RFC.HTTP.Client , RFC.Servant , RFC.Servant.ApiDoc diff --git a/src/RFC/Client/Coinhive.hs b/src/RFC/Client/Coinhive.hs --- a/src/RFC/Client/Coinhive.hs +++ b/src/RFC/Client/Coinhive.hs @@ -2,6 +2,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} @@ -14,6 +16,7 @@ import Data.Aeson.Types as JSON import RFC.API +import RFC.HTTP.Client (HasHttpManager (..)) import RFC.JSON import Servant @@ -21,9 +24,13 @@ import Servant.Client #endif -newtype SecretKey = SecretKey String deriving (FromJSON,ToJSON) -newtype TokenId = TokenId String deriving (FromJSON,ToJSON) +-- |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 @@ -32,6 +39,7 @@ } $(deriveJSON jsonOptions ''TokenVerification) +-- |Arguments required to request verification of a token. data TokenVerifyRequest = TokenVerifyRequest { tvrSecret :: SecretKey , tvrToken :: TokenId @@ -39,126 +47,44 @@ } $(deriveJSON jsonOptions ''TokenVerifyRequest) -data UserCurrentBalance = UserCurrentBalance - { ucbSuccess :: Bool - , ucbName :: String - , ucbTotal :: Integer - , ucbWithdrawn :: Integer - , ucbBalance :: Integer - , ucbError :: Maybe String - } -$(deriveJSON jsonOptions ''UserCurrentBalance) - -data UserWithdrawRequest = UserWithdrawRequest - { uwrSecret :: SecretKey - , uwrName :: String - , uwrAmount :: Integer - } -$(deriveJSON jsonOptions ''UserWithdrawRequest) - -data UserWithdrawl = UserWithdrawl - { uwSuccess :: Bool - , uwName :: String - , uwAmount :: Integer - , uwError :: Maybe String - } -$(deriveJSON jsonOptions ''UserWithdrawl) - -data UserOrdering = - TotalUserOrdering - | BalanceUserOrdering - | WithdrawnUserOrdering - -instance FromJSON UserOrdering where - parseJSON = withText "UserOrdering" $ \v -> - case cs $ toLower v of - "total" -> return TotalUserOrdering - "balance" -> return BalanceUserOrdering - "withdrawn" -> return WithdrawnUserOrdering - _ -> typeMismatch "UserOrdering" (JSON.String v) - -instance ToJSON UserOrdering where - toJSON TotalUserOrdering = toJSON "total" - toJSON BalanceUserOrdering = toJSON "balance" - toJSON WithdrawnUserOrdering = toJSON "withdrawn" - --- |Represents a single user in a 'UserTopReport' or 'UserListReport' -data ReportUser = ReportUser - { ruName :: String - , ruTotal :: Integer - , ruWithdrawn :: Integer - , ruBalance :: Integer - } -$(deriveJSON jsonOptions ''ReportUser) - --- |Report of top users by 'UserOrdering'. -data UserTopReport = UserTopReport - { utrSuccess :: Bool - , utrUsers :: [ReportUser] - , utrError :: Maybe String - } -$(deriveJSON jsonOptions ''UserTopReport) - -data UserListReport = UserListReport - { ulrSuccess :: Bool - , ulrUsers :: [ReportUser] - , ulrNextPage :: Maybe String - , ulrError :: Maybe String - } -$(deriveJSON jsonOptions ''UserListReport) - -data UserResetRequest = UserResetRequest - { urreqSecret :: SecretKey - , urreqName :: String - } -$(deriveJSON jsonOptions ''UserResetRequest) - -data UserResetResult = UserResetResult - { urrSuccess :: Bool - , urrError :: Maybe String - } -$(deriveJSON jsonOptions ''UserResetResult) - - +-- |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 - :<|> UserBalance - :<|> UserWithdraw - :<|> UserTop - :<|> UserList - :<|> UserReset +-- |Endpoint to request verification of a token type TokenVerify = "token" :> "verify" :> JReqBody TokenVerifyRequest :> JPost TokenVerification -type UserBalance = - "user" :> "balance" :> QueryParam "secret" SecretKey :> QueryParam "name" String :> JGet UserCurrentBalance - -type UserWithdraw = - "user" :> "withdraw" :> JReqBody UserWithdrawRequest :> JPost UserWithdrawl - -type UserTop = - "user" :> "top" :> QueryParam "secret" SecretKey :> QueryParam "count" Integer :> QueryParam "order" UserOrdering :> JGet UserTopReport - -type UserList = - "user" :> "list" :> QueryParam "secert" SecretKey :> QueryParam "count" Integer :> QueryParam "page" String :> JGet UserListReport - -type UserReset = - "user" :> "reset" :> JReqBody UserResetRequest :> JPost UserResetResult - #ifndef GHCJS_BROWSER --- |The URL prefix used for Coinhive's API -baseUrl :: BaseUrl -baseUrl = BaseUrl +-- |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 :: (MonadThrow m, MonadIO m, HasHttpManager m) => TokenVerifyRequest -> m TokenVerification +tokenVerify req = do + manager <- getHttpManager + let env = ClientEnv {..} + result <- liftIO $ runClientM (tokenVerifyM req) env + case result of + Left err -> throw err + Right response -> return response + where + baseUrl = apiUrlBase #endif diff --git a/src/RFC/Google/Places/NearbySearch.hs b/src/RFC/Google/Places/NearbySearch.hs deleted file mode 100644 --- a/src/RFC/Google/Places/NearbySearch.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module RFC.Google.Places.NearbySearch - ( module RFC.Google.Places.NearbySearch - , module RFC.Google.Places.SearchResults - , module RFC.Data.LatLng - , HasAPIClient - ) where - -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import RFC.Data.LatLng -import RFC.Google.Places.SearchResults -import RFC.HTTP.Client -import RFC.Log -import RFC.Prelude - -endpoint :: URL -endpoint = - case importURL endpointStr of - Nothing -> error $ "Could not parse the Google Places API endpoint into a URL: " ++ endpointStr - (Just it) -> it - where - endpointStr = "https://maps.googleapis.com/maps/api/place/nearbysearch/json" - -data Params = Params - { apiKey :: String - , location :: LatLng - , radiusMeters :: Integer -- ^ maximum of 50,000 - , rankBy :: RankBy - , keyword :: Maybe String - , language :: Maybe String - , region :: Maybe String - , placeType :: Maybe PlaceType -- ^ "type" - } - -data RankBy = Distance | Prominence - -rankByToString :: RankBy -> String -rankByToString Distance = "distance" -rankByToString Prominence = "prominence" - -data OptionalParams = OptionalParams - -data PlaceType = - Hospital | Doctor - -placeTypeToString :: PlaceType -> String -placeTypeToString Hospital = "hospital" -placeTypeToString Doctor = "doctor" - -paramsToPairs :: Params -> [(String,String)] -paramsToPairs params = - [ ("key", apiKey params) - , ("location", (show lat) ++ "," ++ (show lng)) - , ("radius", show $ radiusMeters params) - , ("rankBy", rankByToString $ rankBy params) - ] ++ optionalPairs - where - loc = location params - (lat,lng) = (latitude loc, longitude loc) - toPair = optionalParamToPair params - optionalPairs = Maybe.catMaybes - [ toPair keyword "keyword" - , toPair language "language" - , toPair region "region" - , toPair (fmap placeTypeToString . placeType) "type" - ] - -optionalParamToPair :: Params -> (Params -> Maybe String) -> String -> Maybe (String,String) -optionalParamToPair param field paramName = (\paramVal -> (paramName, paramVal)) <$> field param - -paramsToUrl :: Params -> URL -paramsToUrl params = - List.foldr fold endpoint $ paramsToPairs params - where - fold = flip add_param - -query :: (HasAPIClient m, MonadUnliftIO m) => Params -> m Results -query params = apiGet (paramsToUrl params) onError - where - onError :: (MonadUnliftIO m) => SomeException -> m Results - onError err = do - logWarn . cs $ "Error performing Google Nearby Search: " ++ (show err) - return $ Results (show err, []) diff --git a/src/RFC/Google/Places/PlaceSearch.hs b/src/RFC/Google/Places/PlaceSearch.hs deleted file mode 100644 --- a/src/RFC/Google/Places/PlaceSearch.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module RFC.Google.Places.PlaceSearch - ( module RFC.Google.Places.PlaceSearch - , module RFC.Google.Places.SearchResults - , module RFC.Data.LatLng - , HasAPIClient - ) where - -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import RFC.Data.LatLng -import RFC.Google.Places.SearchResults -import RFC.HTTP.Client -import RFC.Log -import RFC.Prelude - -endpoint :: URL -endpoint = - case importURL endpointStr of - Nothing -> error $ "Could not parse the Google Place Search API endpoint into a URL: " ++ endpointStr - (Just it) -> it - where - endpointStr = "https://maps.googleapis.com/maps/api/place/textsearch/json" - -data Params = Params - { apiKey :: String - , search :: String - , language :: Maybe String - , placeType :: Maybe PlaceType -- ^ "type" - } - -data PlaceType = - Hospital | Doctor deriving (Show,Eq,Ord,Enum,Bounded,Generic,Typeable) - -placeTypeToString :: PlaceType -> String -placeTypeToString Hospital = "hospital" -placeTypeToString Doctor = "doctor" - -paramsToPairs :: Params -> [(String,String)] -paramsToPairs params = - [ ("key", apiKey params) - , ("query", search params) - ] ++ optionalPairs - where - toPair = optionalParamToPair params - optionalPairs = Maybe.catMaybes - [ toPair language "language" - , toPair (fmap placeTypeToString . placeType) "type" - ] - -optionalParamToPair :: Params -> (Params -> Maybe String) -> String -> Maybe (String,String) -optionalParamToPair param field paramName = (\paramVal -> (paramName, paramVal)) <$> field param - -paramsToUrl :: Params -> URL -paramsToUrl params = - List.foldr fold endpoint $ paramsToPairs params - where - fold = flip add_param - -query :: (MonadUnliftIO m, HasAPIClient m) => Params -> m Results -query params = apiGet (paramsToUrl params) onError - where - onError :: (MonadIO m) => SomeException -> m Results - onError err = do - logWarn . cs $ "Error performing Google Place Search: " ++ (show err) - return $ Results (show err, []) diff --git a/src/RFC/Google/Places/SearchResults.hs b/src/RFC/Google/Places/SearchResults.hs deleted file mode 100644 --- a/src/RFC/Google/Places/SearchResults.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module RFC.Google.Places.SearchResults - ( module RFC.Google.Places.SearchResults - ) where - -import Data.Aeson (withObject, (.:), (.:?)) -import Data.Map as Map -import qualified Data.Maybe as Maybe -import RFC.Data.LatLng -import RFC.JSON -import RFC.Prelude - -type ResultsStatus = String -newtype Results = Results (ResultsStatus, [Result]) - -instance ToJSON Results where - toJSON (Results (status, results)) = - toJSON $ Map.fromList - [ ("status"::String, toJSON status) - , ("results"::String, toJSON results) - ] - -instance FromJSON Results where - parseJSON = withObject "Places.Results" $ \topObj -> do - status <- topObj .: "status" - results <- topObj .:? "results" - return $ Results (status, Maybe.fromMaybe [] results) - -data Result = Result - { resultLocation :: LatLng - , resultName :: String - , resultPlaceId :: String - , resultVicinity :: Maybe String - } - -instance FromJSON Result where - parseJSON = withObject "Places.Result" $ \topObj -> do - geometry <- topObj .: "geometry" - location <- geometry .: "location" - lat <- location .: "lat" - lng <- location .: "lng" - let latLngLoc = latLng lat lng - name <- topObj .: "name" - id <- topObj .: "place_id" - vicinity <- topObj .:? "vicinity" - return $ Result latLngLoc name id vicinity - -instance ToJSON Result where - toJSON result = toJSON . Map.fromList $ - [ ("geometry"::String, toJSON . Map.fromList $ - [ ("location"::String, Map.fromList $ - [ ("lat"::String, latitude . resultLocation $ result) - , ("lng"::String, longitude . resultLocation $ result) - ] - ) - ] - ) - , ("name"::String, toJSON . resultName $ result) - , ("place_id"::String, toJSON . resultPlaceId $ result) - , ("vicinity"::String, toJSON . resultVicinity $ result) - ] diff --git a/src/RFC/HTTP/Client.hs b/src/RFC/HTTP/Client.hs --- a/src/RFC/HTTP/Client.hs +++ b/src/RFC/HTTP/Client.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE UndecidableInstances #-} module RFC.HTTP.Client ( withAPISession , HasAPIClient(..) + , HasHttpManager(..) , BadStatusException , apiGet , module Network.Wreq.Session @@ -14,23 +17,32 @@ ) where import Control.Lens +import Control.Monad.Catch +import Network.HTTP.Client (Manager, ManagerSettings, + newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types.Status hiding (statusCode, statusMessage) import Network.URL import Network.Wreq.Lens import Network.Wreq.Session hiding (withAPISession) import RFC.JSON (FromJSON, decodeOrDie) -import RFC.Prelude +import RFC.Prelude hiding (handle) import RFC.String +rfcManagerSettings :: ManagerSettings +rfcManagerSettings = tlsManagerSettings + +createRfcManager :: IO Manager +createRfcManager = newManager rfcManagerSettings + withAPISession :: (Session -> IO a) -> IO a -withAPISession = (>>=) $ newSessionControl Nothing tlsManagerSettings +withAPISession = (>>=) $ newSessionControl Nothing rfcManagerSettings newtype BadStatusException = BadStatusException (Status,URL) deriving (Show,Eq,Ord,Generic,Typeable) instance Exception BadStatusException -apiExecute :: (HasAPIClient m, ConvertibleString LazyByteString s) => +apiExecute :: (HasAPIClient m, MonadIO m, ConvertibleString LazyByteString s) => URL -> (Session -> String -> IO (Response LazyByteString)) -> (s -> m a) -> m a apiExecute rawUrl action converter = do session <- getAPIClient @@ -43,9 +55,15 @@ url = exportURL rawUrl badResponseStatus status = BadStatusException (status, rawUrl) -apiGet :: (HasAPIClient m, FromJSON a, MonadUnliftIO m, Exception e) => URL -> (e -> m a) -> m a +apiGet :: (HasAPIClient m, FromJSON a, MonadIO m, MonadCatch m, Exception e) => URL -> (e -> m a) -> m a apiGet url onError = handle onError $ apiExecute url get decodeOrDie -class (MonadIO m) => HasAPIClient m where +class HasAPIClient m where getAPIClient :: m Session + +class HasHttpManager m where + getHttpManager :: m Manager + +instance (MonadIO m) => HasHttpManager m where + getHttpManager = liftIO createRfcManager diff --git a/src/RFC/JSON.hs b/src/RFC/JSON.hs --- a/src/RFC/JSON.hs +++ b/src/RFC/JSON.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} module RFC.JSON ( jsonOptions @@ -21,6 +19,7 @@ ) where import ClassyPrelude +import Control.Monad.Catch import Data.Aeson as JSON import Data.Aeson.Parser as JSONParser import Data.Aeson.TH (deriveJSON) @@ -68,10 +67,10 @@ newtype DecodeError = DecodeError (LazyByteString, String) deriving (Show,Eq,Ord,Generic,Typeable) instance Exception DecodeError -decodeOrDie :: (FromJSON a, MonadIO m) => LazyByteString -> m a +decodeOrDie :: (FromJSON a, MonadThrow m) => LazyByteString -> m a decodeOrDie input = case decodeEither' input of - Left err -> throwIO $ DecodeError (input, err) + Left err -> throwM $ DecodeError (input, err) Right a -> return a instance FromHttpApiData JSON.Value where diff --git a/src/RFC/Miso.hs b/src/RFC/Miso.hs new file mode 100644 --- /dev/null +++ b/src/RFC/Miso.hs @@ -0,0 +1,12 @@ +{-# 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 diff --git a/src/RFC/Miso/Inject.hs b/src/RFC/Miso/Inject.hs new file mode 100644 --- /dev/null +++ b/src/RFC/Miso/Inject.hs @@ -0,0 +1,15 @@ +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 () diff --git a/src/RFC/Miso/String.hs b/src/RFC/Miso/String.hs new file mode 100644 --- /dev/null +++ b/src/RFC/Miso/String.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + + +module RFC.Miso.String + ( module RFC.Miso.String + ) where + +import Data.Function (id) +import Data.String (String) +import Data.String.Conversions +import Miso.String (MisoString, ToMisoString (..)) + +instance {-# OVERLAPPING #-} ConvertibleStrings MisoString MisoString where + convertString = id + +instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings MisoString str where + {-# SPECIALIZE instance ConvertibleStrings MisoString LazyText #-} + {-# SPECIALIZE instance ConvertibleStrings MisoString StrictText #-} + {-# SPECIALIZE instance ConvertibleStrings MisoString LazyByteString #-} + {-# SPECIALIZE instance ConvertibleStrings MisoString StrictByteString #-} + {-# SPECIALIZE instance ConvertibleStrings MisoString String #-} + convertString = fromMisoString + +instance {-# OVERLAPPABLE #-} (ToMisoString str) => ConvertibleStrings str MisoString where + {-# SPECIALIZE instance ConvertibleStrings LazyText MisoString #-} + {-# SPECIALIZE instance ConvertibleStrings StrictText MisoString #-} + {-# SPECIALIZE instance ConvertibleStrings LazyByteString MisoString #-} + {-# SPECIALIZE instance ConvertibleStrings StrictByteString MisoString #-} + {-# SPECIALIZE instance ConvertibleStrings String MisoString #-} + convertString = toMisoString + diff --git a/src/RFC/Miso/XHR.hs b/src/RFC/Miso/XHR.hs new file mode 100644 --- /dev/null +++ b/src/RFC/Miso/XHR.hs @@ -0,0 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-dodgy-exports #-} + +module RFC.Miso.XHR + ( module RFC.Miso.XHR + ) where + +import RFC.Prelude () diff --git a/src/RFC/Prelude.hs b/src/RFC/Prelude.hs --- a/src/RFC/Prelude.hs +++ b/src/RFC/Prelude.hs @@ -14,10 +14,18 @@ , module Data.Bifoldable , module Data.Default , module Control.Monad.Trans.Control + , module Control.Monad.Catch ) where -import ClassyPrelude hiding (Day, Handler, unpack) +import ClassyPrelude hiding (Day, Handler, bracket, + bracketOnError, bracket_, catch, + catchJust, catches, finally, + handle, handleJust, mask, mask_, + onException, try, tryJust, + uninterruptibleMask, + uninterruptibleMask_, unpack) import Control.Monad (forever, void, (<=<), (>=>)) +import Control.Monad.Catch import Control.Monad.Trans.Control import Data.Bifoldable import Data.Bifunctor @@ -54,10 +62,7 @@ safeHead [] = Nothing safeHead (x:_) = Just x -throwM :: (MonadIO m, Exception e) => e -> m a -throwM = throwIO - -throw :: (MonadIO m, Exception e) => e -> m a -throw = throwIO +throw :: (MonadThrow m, Exception e) => e -> m a +throw = throwM type Boolean = Bool -- I keep forgetting which Haskell uses.... diff --git a/src/RFC/Redis.hs b/src/RFC/Redis.hs --- a/src/RFC/Redis.hs +++ b/src/RFC/Redis.hs @@ -21,7 +21,7 @@ newtype RedisException = RedisException R.Reply deriving (Typeable, Show) instance Exception RedisException -class (MonadIO m) => HasRedis m where +class (MonadThrow m, MonadIO m) => HasRedis m where getRedisPool :: m ConnectionPool runRedis :: R.Redis a -> m a @@ -40,11 +40,11 @@ maybeResult <- unpack result return $ cs <$> maybeResult -unpack :: (MonadIO m) => Either R.Reply a -> m a +unpack :: (MonadThrow m) => Either R.Reply a -> m a unpack (Left reply) = throw $ RedisException reply unpack (Right it) = return it -setex :: (MonadIO m, HasRedis m, ConvertibleToSBS key, ConvertibleToSBS value, TimeUnit expiry) => key -> value -> expiry -> m () +setex :: (HasRedis m, ConvertibleToSBS key, ConvertibleToSBS value, TimeUnit expiry) => key -> value -> expiry -> m () setex key value expiry = do result <- runRedis $ R.setex (cs key) milliseconds (cs value) _ <- unpack result diff --git a/src/RFC/Servant.hs b/src/RFC/Servant.hs --- a/src/RFC/Servant.hs +++ b/src/RFC/Servant.hs @@ -34,7 +34,7 @@ import RFC.Data.IdAnd import RFC.HTTP.Client import RFC.JSON () -import RFC.Prelude hiding (handleJust) +import RFC.Prelude hiding (Handler, handleJust) import qualified RFC.Psql as Psql import qualified RFC.Redis as Redis import Servant diff --git a/src/RFC/Servant/ApiDoc.hs b/src/RFC/Servant/ApiDoc.hs --- a/src/RFC/Servant/ApiDoc.hs +++ b/src/RFC/Servant/ApiDoc.hs @@ -45,13 +45,17 @@ _ -> failMethodNotAllowed where html = Blaze.renderHtml $ apiToHtml api + ascii :: LazyByteString ascii = apiToAscii api + swaggerToLbs :: Swagger -> LazyByteString swaggerToLbs = Builder.toLazyByteString . fromEncoding . toEncoding swagger = swaggerToLbs $ apiToSwagger api + reqMethod :: String reqMethod = map Char.toUpper $ cs $ requestMethod request + pathInfo :: String pathInfo = map Char.toLower $ cs $ rawPathInfo request checkPath = - case map Char.toLower (cs $ rawPathInfo request) of + case pathInfo of "swagger.json" -> serveSwagger "/swagger.json" -> serveSwagger "api.html" -> serveHtml @@ -59,13 +63,18 @@ "api.txt" -> serveTxt "/api.txt" -> serveTxt _ -> failPathNotFound + response :: + (ConvertibleStrings contentType StrictByteString, ConvertibleStrings body LazyByteString) => + contentType -> body -> IO ResponseReceived response contentType body = callback $ - responseLBS status200 [(hContentType, cs contentType)] body - serveHtml = response "text/html" (cs html) + responseLBS status200 [(hContentType, cs contentType)] (cs body) + serveHtml = response "text/html" html serveTxt = response "text/plain" ascii serveSwagger = response "application/json" swagger + failMethodNotAllowed :: IO ResponseReceived failMethodNotAllowed = callback $ responseLBS status405 [(hContentType, cs "text/plain")] (cs $ "Unsupported HTTP method: " ++ reqMethod) + failPathNotFound :: IO ResponseReceived failPathNotFound = callback $ responseLBS status404 [(hContentType, cs "text/plain")] (cs $ "Path not found: " ++ pathInfo) diff --git a/src/RFC/String.hs b/src/RFC/String.hs --- a/src/RFC/String.hs +++ b/src/RFC/String.hs @@ -7,6 +7,7 @@ , module Data.String.Conversions.Monomorphic ) where +import Data.String (String) import Data.String.Conversions hiding ((<>)) import Data.String.Conversions.Monomorphic hiding (fromString, toString) @@ -14,5 +15,7 @@ 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 ConvertibleFromString a = ConvertibleStrings String a