rfc 0.0.0.17 → 0.0.0.18
raw patch · 16 files changed
+177/−362 lines, 16 filesdep +http-clientdep +misodep ~http-api-datadep ~waidep ~wreq
Dependencies added: http-client, miso
Dependency ranges changed: http-api-data, wai, wreq
Files
- rfc.cabal +18/−14
- src/RFC/Client/Coinhive.hs +32/−106
- src/RFC/Google/Places/NearbySearch.hs +0/−86
- src/RFC/Google/Places/PlaceSearch.hs +0/−69
- src/RFC/Google/Places/SearchResults.hs +0/−63
- src/RFC/HTTP/Client.hs +23/−5
- src/RFC/JSON.hs +5/−6
- src/RFC/Miso.hs +12/−0
- src/RFC/Miso/Inject.hs +15/−0
- src/RFC/Miso/String.hs +35/−0
- src/RFC/Miso/XHR.hs +7/−0
- src/RFC/Prelude.hs +11/−6
- src/RFC/Redis.hs +3/−3
- src/RFC/Servant.hs +1/−1
- src/RFC/Servant/ApiDoc.hs +12/−3
- src/RFC/String.hs +3/−0
rfc.cabal view
@@ -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
src/RFC/Client/Coinhive.hs view
@@ -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
− src/RFC/Google/Places/NearbySearch.hs
@@ -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, [])
− src/RFC/Google/Places/PlaceSearch.hs
@@ -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, [])
− src/RFC/Google/Places/SearchResults.hs
@@ -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)- ]
src/RFC/HTTP/Client.hs view
@@ -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
src/RFC/JSON.hs view
@@ -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
+ src/RFC/Miso.hs view
@@ -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
+ src/RFC/Miso/Inject.hs view
@@ -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 ()
+ src/RFC/Miso/String.hs view
@@ -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+
+ src/RFC/Miso/XHR.hs view
@@ -0,0 +1,7 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports #-}++module RFC.Miso.XHR+ ( module RFC.Miso.XHR+ ) where++import RFC.Prelude ()
src/RFC/Prelude.hs view
@@ -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....
src/RFC/Redis.hs view
@@ -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
src/RFC/Servant.hs view
@@ -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
src/RFC/Servant/ApiDoc.hs view
@@ -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)
src/RFC/String.hs view
@@ -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