packages feed

rfc (empty) → 0.0.0.1

raw patch · 25 files changed

+1273/−0 lines, 25 filesdep +aesondep +aeson-diffdep +asyncsetup-changed

Dependencies added: aeson, aeson-diff, async, base, blaze-html, classy-prelude, containers, data-default, exceptions, hedis, http-api-data, http-client-tls, http-types, lens, lifted-async, markdown, monad-control, postgresql-simple, resource-pool, servant, servant-blaze, servant-docs, servant-server, servant-swagger, simple-logger, string-conversions, swagger2, temporary, text, time-units, unordered-containers, url, uuid-types, vector, wai, wai-cors, wai-extra, wreq

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Robert Fischer (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Robert Fischer nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# Request For Comments+## aka: Robert Fischer Commons++This is a place where I put Haskell that I like to use, and things that I would eventually like to break out into libraries,+but I want to exercise/refine the API first.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rfc.cabal view
@@ -0,0 +1,108 @@+name:                rfc+version:             0.0.0.1+synopsis:            Robert Fischer's Common library, for all Robert Fischer's common needs.+description:         See README.md+homepage:            https://github.com/RobertFischer/rfc#README.md+license:             BSD3+license-file:        LICENSE+author:              Robert Fischer+maintainer:          smokejumperit+rfc@gmail.com+copyright:           (c)2017 Robert Fischer+category:            Library+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++Flag Development+  Description: Enable warnings+  Default:     False+  Manual:      True++library+  hs-source-dirs:      src+  build-depends:       base >= 4.7 && < 5+  default-language:    Haskell2010+  if flag(development)+    ghc-options:       -pedantic -fno-warn-orphans -fno-warn-name-shadowing+  else+    ghc-options:       -O2+  default-extensions:  NoImplicitPrelude+                     , DataKinds+                     , TemplateHaskell+                     , TypeOperators+                     , OverloadedStrings+                     , PackageImports+                     , LambdaCase+                     , MultiWayIf+                     , Rank2Types+                     , ConstraintKinds+                     , FlexibleContexts+                     , TypeSynonymInstances+                     , FlexibleInstances+                     , DeriveGeneric+                     , ScopedTypeVariables+                     , MultiParamTypeClasses+                     , DefaultSignatures+  build-depends:       base >= 4.7 && < 5+                     , aeson+                     , servant+                     , servant-server+                     , wai+                     , classy-prelude+                     , uuid-types+                     , containers+                     , unordered-containers+                     , string-conversions+                     , monad-control+                     , postgresql-simple >= 0.5.3.0+                     , resource-pool+                     , hedis+                     , async+                     , simple-logger+                     , http-client-tls+                     , wreq+                     , servant-docs+                     , data-default+                     , servant-blaze+                     , wai-extra+                     , temporary+                     , blaze-html+                     , servant-swagger+                     , swagger2+                     , markdown+                     , url+                     , lens+                     , http-types+                     , exceptions+                     , http-api-data+                     , time-units+                     , wai-cors+                     , aeson-diff+                     , vector+                     , lifted-async+                     , text+  exposed-modules:     RFC.Prelude+                     , RFC.Psql+                     , RFC.Redis+                     , RFC.String+                     , RFC.Concurrent+                     , RFC.Throttle+                     , RFC.JSON+                     , RFC.Log+                     , RFC.HTTP.Client+                     , RFC.HTTP.Types+                     , RFC.Servant+                     , RFC.Servant.ApiDoc+                     , RFC.Wai+                     , RFC.Env+                     , RFC.Google.Places.NearbySearch+                     , RFC.Google.Places.PlaceSearch+                     , RFC.Google.Places.SearchResults+                     , RFC.Data.LatLng+                     , RFC.Data.IdAnd+                     , RFC.Data.ListMoveDirection+                     , RFC.Data.UUID++source-repository head+  type:     git+  location: https://github.com/RobertFischer/rfc
+ src/RFC/Concurrent.hs view
@@ -0,0 +1,22 @@+module RFC.Concurrent+  ( module RFC.Concurrent+  , module Control.Concurrent.Async.Lifted+  ) where++import RFC.Prelude hiding (mapConcurrently)+import Control.Concurrent.Async.Lifted (mapConcurrently, mapConcurrently_)++-- |Executes all the IO actions simultaneously and returns the original data structure with the arguments replaced+--  by the results of the execution.+doConcurrently :: (Traversable t, MonadBaseControl IO m) => t (m a) -> m (t a)+doConcurrently = mapConcurrently id++-- |Executes all the IO actions simulataneously and discards the results.+doConcurrently_ :: (Foldable f, MonadBaseControl IO m) => f (m a) -> m ()+doConcurrently_ = mapConcurrently_ id++-- |Executes all the IO actions simultaneously, feeds them into the filter function, and then+-- filters the results.+filterConcurrently :: (MonadBaseControl IO m) => (a -> Bool) -> [m a] -> m [a] -- TODO Seems like we should be able to do this with Foldable/Traversable+filterConcurrently filterFunc actions =+    filter filterFunc <$> doConcurrently actions
+ src/RFC/Data/IdAnd.hs view
@@ -0,0 +1,52 @@+module RFC.Data.IdAnd+  ( idAndsToMap+  , IdAnd(..)+  , valuesToIdAnd+  , idAndToTuple+  , tupleToIdAnd+  , idAndToPair+  ) where++import RFC.Prelude+import RFC.JSON+import Data.Aeson as JSON+import Data.Map as Map+import Data.List as List hiding ((++))+import Database.PostgreSQL.Simple.ToRow+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.ToField+import Database.PostgreSQL.Simple.FromField()++-- |Represents something which has an ID.+newtype IdAnd a = IdAnd (UUID, a)+  deriving (Eq, Ord, Show, Generic, Typeable)++tupleToIdAnd :: (UUID, a) -> IdAnd a+tupleToIdAnd = IdAnd++valuesToIdAnd :: UUID -> a -> IdAnd a+valuesToIdAnd id a = IdAnd(id,a)++idAndToTuple :: IdAnd a -> (UUID, a)+idAndToTuple (IdAnd it) = it++idAndToPair :: IdAnd a -> (UUID, IdAnd a)+idAndToPair idAnd@(IdAnd (id,_)) = (id, idAnd)++idAndsToMap :: [IdAnd a] -> Map UUID a+idAndsToMap list = Map.fromList $ List.map idAndToTuple list++instance (FromJSON a) => FromJSON (IdAnd a) where+  parseJSON = JSON.withObject "IdAnd" $ \o -> do+    id <- o .: "id"+    value <- o .: "value"+    return $ IdAnd(id, value)++instance (ToJSON a) => ToJSON (IdAnd a) where+  toJSON (IdAnd (id,value)) = object [ "id".=id, "value".=value ]++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
+ src/RFC/Data/LatLng.hs view
@@ -0,0 +1,53 @@+module RFC.Data.LatLng+  ( LatLng(..)+  , Longitude+  , Latitude+  , latLng+  , lngLat+  ) where++import RFC.Prelude+import RFC.Psql as Psql+import RFC.JSON as JSON++type Latitude = Double+type Longitude = Double+++data LatLng = LatLng {+  latitude :: Latitude,+  longitude :: Longitude+} deriving (Eq, Ord, Show, Typeable, Generic)+$(JSON.deriveJSON JSON.jsonOptions ''LatLng)++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+++latLng :: Latitude -> Longitude -> LatLng+latLng lat lng = LatLng lat lng++lngLat :: Longitude -> Latitude -> LatLng+lngLat = flip latLng
+ src/RFC/Data/ListMoveDirection.hs view
@@ -0,0 +1,50 @@+module RFC.Data.ListMoveDirection (+  module RFC.Data.ListMoveDirection+) where++import RFC.Prelude+import RFC.JSON+import Data.Text as Text+import Data.Aeson as Aeson++data ListMoveDirection = TowardsHead | TowardsTail+  deriving (Show,Eq,Generic,Typeable)++instance FromJSON ListMoveDirection where+    parseJSON = withText "ListMoveDirection" $ \t -> do+      let head = return TowardsHead+      let tail = return TowardsTail+      case Text.strip $ Text.toUpper t of+        "UP" -> head+        "DOWN" -> tail++        "FORWARD" -> head+        "BACKWARD" -> tail++        "FRONT" -> head+        "BACK" -> tail++        "-1" -> head+        "+1" -> tail++        "TOWARDSSTART" -> head+        "TOWARDSTART" -> head+        "TOWARDSEND" -> tail++        "TOWARDSFRONT" -> head+        "TOWARDSBACK" -> tail++        "TOWARDSHEAD" -> head+        "TOWARDSTAIL" -> tail++        "HEADWARDS" -> head+        "TAILWARDS" -> tail++        _ -> fail . cs $ Text.append "Could not parse string to direction: " t++instance ToJSON ListMoveDirection where+  toJSON dir = Aeson.String (+    case dir of+      TowardsHead -> "UP"+      TowardsTail -> "DOWN"+    )
+ src/RFC/Data/UUID.hs view
@@ -0,0 +1,34 @@+module RFC.Data.UUID+  ( module Data.UUID.Types+  ) where++import Prelude (return, ($), String)+import Data.UUID.Types+import qualified Data.UUID.Types as UUID+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.ToRow+import Database.PostgreSQL.Simple.Types (Only(..))+import RFC.String++instance FromRow UUID where+  fromRow = do+    (Only id) <- fromRow+    return id++instance ToRow UUID where+  toRow id = toRow $ Only id++instance ConvertibleStrings UUID String where+  convertString = UUID.toString++instance ConvertibleStrings UUID StrictText where+  convertString = UUID.toText++instance ConvertibleStrings UUID LazyText where+  convertString = toLazyText++instance ConvertibleStrings UUID StrictByteString where+  convertString = UUID.toASCIIBytes++instance ConvertibleStrings UUID LazyByteString where+  convertString = UUID.toLazyASCIIBytes
+ src/RFC/Env.hs view
@@ -0,0 +1,111 @@+module RFC.Env+  ( readGoogleMapsAPIKey+  , isDevelopment+  , readEnvironment+  , readPsqlConnectInfo+  , readRedisConnectInfo+  ) where++import RFC.Prelude+import System.Environment (lookupEnv)+import Database.PostgreSQL.Simple as Psql+import Database.Redis as Redis+import Data.Word (Word16)++-- TODO Create a Monad that only logs reading the env var once, and reads all the environment variables at once, and is pure.++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++isDevelopment :: (MonadIO m) =>  m Bool+isDevelopment = ((==) "development") <$> readEnvironment++forDevOnly :: (MonadIO m) => String -> m (Maybe String)+forDevOnly defaultValue = do+  isDev <- isDevelopment+  return $ if isDev then+    Just defaultValue+  else+    Nothing++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++readPsqlPort :: (MonadIO m) => m Word16+readPsqlPort = do+  result <- readEnv "PSQL_PORT" $ Just $ show $ Psql.connectPort Psql.defaultConnectInfo+  return $ read result++readPsqlConnectInfo :: (MonadIO m) => m Psql.ConnectInfo+readPsqlConnectInfo =+  Psql.ConnectInfo+    <$> readPsqlHost+    <*> readPsqlPort+    <*> readPsqlUser+    <*> readPsqlPassword+    <*> readPsqlDatabase++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)++readRedisHost :: (MonadIO m) => m Redis.HostName+readRedisHost = readEnv "REDIS_HOST" $ Just $ Redis.connectHost Redis.defaultConnectInfo++readRedisPort :: (MonadIO m) => m Redis.PortID+readRedisPort = do+  result <- readEnv "REDIS_PORT" $ Just "6379" -- Default Redis port+  return $ PortNumber $ read result++readRedisPassword :: (MonadIO m) => m (Maybe ByteString)+readRedisPassword = do+  result <- readEnv "REDIS_PASSWORD" $ Just ""+  return $+    case result of+      "" -> Nothing+      _ -> Just $ cs result++readRedisDbNumber :: (MonadIO m) => m Integer+readRedisDbNumber = read <$> readEnv "REDIS_DATABASE" (Just $ show $ Redis.connectDatabase Redis.defaultConnectInfo)++readAppSlug :: (MonadIO m) => m String+readAppSlug = readEnv "APP_SLUG" Nothing
+ src/RFC/Google/Places/NearbySearch.hs view
@@ -0,0 +1,83 @@+module RFC.Google.Places.NearbySearch+  ( module RFC.Google.Places.NearbySearch+  , module RFC.Google.Places.SearchResults+  , module RFC.Data.LatLng+  , HasAPIClient+  ) where++import RFC.Prelude+import RFC.Log+import RFC.HTTP.Client+import qualified Data.Maybe as Maybe+import qualified Data.List as List+import RFC.Data.LatLng+import RFC.Google.Places.SearchResults++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, MonadCatch 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 Nearby Search: " ++ (show err)+      return $ Results (show err, [])
+ src/RFC/Google/Places/PlaceSearch.hs view
@@ -0,0 +1,65 @@+module RFC.Google.Places.PlaceSearch+  ( module RFC.Google.Places.PlaceSearch+  , module RFC.Google.Places.SearchResults+  , module RFC.Data.LatLng+  , HasAPIClient+  ) where++import RFC.Prelude+import RFC.Log+import RFC.HTTP.Client+import qualified Data.Maybe as Maybe+import qualified Data.List as List+import RFC.Data.LatLng+import RFC.Google.Places.SearchResults++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 :: (MonadCatch 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 view
@@ -0,0 +1,60 @@+module RFC.Google.Places.SearchResults+  ( module RFC.Google.Places.SearchResults+  ) where++import Data.Aeson ((.:), (.:?), withObject)+import RFC.Prelude+import RFC.JSON+import qualified Data.Maybe as Maybe+import RFC.Data.LatLng+import Data.Map as Map++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
@@ -0,0 +1,46 @@+module RFC.HTTP.Client+  ( withAPISession+  , HasAPIClient(..)+  , BadStatusException+  , apiGet+  , module Network.Wreq.Session+  , module Network.URL+  , module Network.HTTP.Types.Status+  ) where++import RFC.Prelude+import RFC.String+import RFC.JSON (FromJSON, decodeOrDie)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.Wreq.Session hiding (withAPISession)+import Network.URL+import Network.Wreq.Lens+import Control.Lens+import Network.HTTP.Types.Status hiding (statusMessage, statusCode)++withAPISession :: (Session -> IO a) -> IO a+withAPISession = withSessionControl Nothing tlsManagerSettings++newtype BadStatusException = BadStatusException (Status,URL)+  deriving (Show,Eq,Ord,Generic,Typeable)+instance Exception BadStatusException++apiExecute :: (HasAPIClient m, ConvertibleString LazyByteString s)  =>+  URL -> (Session -> String -> IO (Response LazyByteString)) -> (s -> m a) -> m a+apiExecute rawUrl action converter = do+    session <- getAPIClient+    response <- liftIO $ action session url+    let status = response ^. responseStatus+    case status ^. statusCode of+      200 -> converter . cs $ response ^. responseBody+      _ -> throwM $ badResponseStatus status+  where+    url = exportURL rawUrl+    badResponseStatus status = BadStatusException (status, rawUrl)++apiGet :: (HasAPIClient m, FromJSON a, MonadCatch m, Exception e) => URL -> (e -> m a) -> m a+apiGet url onError =+    handle onError $ apiExecute url get decodeOrDie++class (MonadThrow m, MonadIO m) => HasAPIClient m where+  getAPIClient :: m Session
+ src/RFC/HTTP/Types.hs view
@@ -0,0 +1,5 @@+module RFC.HTTP.Types+  ( module Web.HttpApiData+  ) where++import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..))
+ src/RFC/JSON.hs view
@@ -0,0 +1,51 @@+module RFC.JSON+( jsonOptions+, deriveJSON+, FromJSON(..)+, ToJSON(..)+, eitherDecode+, decodeEither+, eitherDecode'+, decodeEither'+, decodeOrDie+, DecodeError+, Value(..)+, encode+, decode+) where++import RFC.Prelude+import Data.Aeson as JSON+import Data.Aeson.TH (deriveJSON)+import Data.Aeson.Types (Options(..), SumEncoding(..))++jsonOptions :: Options+jsonOptions = defaultOptions+    { sumEncoding = ObjectWithSingleField+    , unwrapUnaryRecords = True+    , fieldLabelModifier = flm+    , constructorTagModifier = ctm+    }+  where+    ctm [] = []+    ctm (c:cs) = (charToLower c):cs+    flm = flm' . span charIsLower+    flm' (cs, []) = cs+    flm' (_, cs) = lowerFirst cs+    lowerFirst [] = []+    lowerFirst (c:cs) = (charToLower c):cs++decodeEither :: (FromJSON a) => LazyByteString -> Either String a+decodeEither = eitherDecode++decodeEither' :: (FromJSON a) => LazyByteString -> Either String a+decodeEither' = eitherDecode'++newtype DecodeError = DecodeError (LazyByteString, String) deriving (Show,Eq,Ord,Generic,Typeable)+instance Exception DecodeError++decodeOrDie :: (FromJSON a, MonadThrow m) => LazyByteString -> m a+decodeOrDie input =+  case decodeEither' input of+    Left err -> throwM $ DecodeError (input, err)+    Right a -> return a
+ src/RFC/Log.hs view
@@ -0,0 +1,24 @@+module RFC.Log+  ( module Control.Logger.Simple+  , module RFC.Log+  ) where++import RFC.Prelude+import RFC.Env as Env+import Control.Logger.Simple (pureDebug, pureInfo, pureWarn, pureError, logDebug, logInfo, logWarn, logError)+import Control.Logger.Simple as Log+import System.IO (stderr, hSetBuffering, BufferMode(..))++withLogging :: IO a -> IO a+withLogging action = do+  isDev <- Env.isDevelopment+  hSetBuffering stderr LineBuffering+  Log.withGlobalLogging (logConfig isDev) action+  where+    logConfig isDev =+      if isDev then+          Log.LogConfig { Log.lc_file = Nothing, Log.lc_stderr = True }+      else+          Log.LogConfig { Log.lc_file = Just "./log/api-server.log", Log.lc_stderr = False }++
+ src/RFC/Prelude.hs view
@@ -0,0 +1,44 @@+module RFC.Prelude+  ( module ClassyPrelude+  , module RFC.Prelude+  , module RFC.Data.UUID+  , module Data.String.Conversions+  , module GHC.Generics+  , module Text.Read+  , module Data.Time.Units+  , module Data.Function+  , module Data.Typeable+  ) where++import Prelude ()+import ClassyPrelude hiding (Handler, unpack, Day)+import Data.Char as Char+import Data.String.Conversions (cs, LazyByteString, StrictByteString, LazyText, StrictText)+import GHC.Generics (Generic)+import qualified Data.List as List+import Text.Read (Read, read)+import Data.Time.Units+import RFC.Data.UUID (UUID)+import Data.Function ((&))+import Data.Typeable (TypeRep, typeOf)++charIsUpper :: Char -> Bool+charIsUpper = Char.isUpper++charIsLower :: Char -> Bool+charIsLower = Char.isLower++uniq :: (Eq a) => [a] -> [a]+uniq = List.nub++mapFst :: (a -> c) -> (a,b) -> (c,b)+mapFst f (a,b) = (f a, b)++mapSnd :: (b -> c) -> (a,b) -> (a,c)+mapSnd f (a,b) = (a, f b)++safeHead :: [a] -> Maybe a+safeHead [] = Nothing+safeHead (x:_) = Just x++type Boolean = Bool -- I keep forgetting which Haskell uses....
+ src/RFC/Psql.hs view
@@ -0,0 +1,95 @@+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 RFC.Psql+  ) where++import RFC.Prelude+import RFC.Env+import Database.PostgreSQL.Simple (Connection, connectUser, connectPassword, connectDatabase, ConnectInfo, FromRow, Only(..), In(..), commit, Query)+import qualified Database.PostgreSQL.Simple as Psql+import Data.Pool+import Database.PostgreSQL.Simple.FromField hiding (Binary)+import Database.PostgreSQL.Simple.FromRow+import Database.PostgreSQL.Simple.ToField+import Database.PostgreSQL.Simple.ToRow+import Database.PostgreSQL.Simple.SqlQQ+import Database.PostgreSQL.Simple.Types+import Control.Monad.Trans.Control+import RFC.Log++type ConnectionPool = Pool Connection++class (MonadIO m, MonadCatch m, MonadBaseControl IO m) => HasPsql m where+  getPsqlPool :: m ConnectionPool++  withPsqlConnection :: (Connection -> m a) -> m a+  withPsqlConnection action = do+    pool <- getPsqlPool+    withResource pool action++  withPsqlTransaction :: (Connection -> m a) -> m a+  withPsqlTransaction action = withPsqlConnection $ \conn ->+    (liftBaseOp_ (Psql.withTransaction conn)) (action conn)++defaultConnectInfo :: (MonadIO m) => m ConnectInfo+defaultConnectInfo = RFC.Env.readPsqlConnectInfo++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++query :: (MonadIO m, FromRow r, ToRow q) => Connection -> Query -> q -> m [r]+query conn qry q = liftIO $ Psql.query conn qry q++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++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++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++query1Else_ :: (MonadIO m, FromRow r, Exception e) => Connection -> Query -> e -> m (Maybe r)+query1Else_ conn qry e = do+  result <- query1_ conn 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++execute_ :: (MonadIO m) => Connection -> Query -> m Int64+execute_ conn qry = liftIO $ Psql.execute_ conn qry++executeMany :: (MonadIO m, ToRow q) => Connection -> Query -> [q] -> m Int64+executeMany conn qry qs = liftIO $ Psql.executeMany conn qry qs
+ src/RFC/Redis.hs view
@@ -0,0 +1,49 @@+module RFC.Redis+  ( createConnectionPool+  , ConnectionPool+  , HasRedis(..)+  , RedisException(..)+  , get+  , setex+  ) where++import RFC.Prelude+import qualified Database.Redis as R+import RFC.String+import RFC.Env as Env++type ConnectionPool = R.Connection++newtype RedisException = RedisException R.Reply deriving (Typeable, Show)+instance Exception RedisException++class (MonadIO m, MonadThrow m) => HasRedis m where+  getRedisPool :: m ConnectionPool++  runRedis :: R.Redis a -> m a+  runRedis r = do+    conn <- getRedisPool+    liftIO $ R.runRedis conn r++createConnectionPool :: (MonadIO m) => m ConnectionPool+createConnectionPool = do+  connInfo <- Env.readRedisConnectInfo+  liftIO $ R.connect connInfo++get :: (HasRedis m, ConvertibleToSBS tIn, ConvertibleFromSBS tOut) => tIn -> m (Maybe tOut)+get key = do+  result <- runRedis $ R.get $ cs key+  maybeResult <- unpack result+  return $ cs <$> maybeResult++unpack :: (MonadThrow m) => Either R.Reply a -> m a+unpack (Left reply) = throw $ RedisException reply+unpack (Right it) = return it++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+    return ()+  where+    milliseconds = fromIntegral $ ( (convertUnit expiry)::Millisecond )
+ src/RFC/Servant.hs view
@@ -0,0 +1,157 @@+module RFC.Servant+  ( ApiCtx+  , apiCtxToHandler+  , ResourceDefinition(..)+  , ServerAPI+  , ServerImpl+  , module Servant+  , module Servant.Docs+  , module Servant.HTML.Blaze+  , module Text.Blaze.Html+  , module Data.Swagger+  , module RFC.Data.IdAnd+  ) where++import RFC.Prelude+import Servant+import qualified RFC.Redis as Redis+import qualified RFC.Psql as Psql+import RFC.JSON+import RFC.HTTP.Client+import Data.Aeson as JSON+import Servant.Docs hiding (API)+import Servant.HTML.Blaze (HTML)+import Text.Blaze.Html+import Data.Swagger (Swagger, ToSchema)+import Network.Wreq.Session as Wreq+import qualified Data.Aeson.Diff as JSON+import Database.PostgreSQL.Simple (SqlError(..))+import RFC.Data.IdAnd+import qualified Data.Map.Strict as Map++type ApiCtx =+  ReaderT Wreq.Session+    ( ReaderT Psql.ConnectionPool+      ( ReaderT Redis.ConnectionPool+        Handler+      )+    )++instance HasAPIClient ApiCtx where+  getAPIClient = ask++instance Psql.HasPsql ApiCtx where+  getPsqlPool = lift ask++instance Redis.HasRedis ApiCtx where+  getRedisPool = lift $ lift ask++apiCtxToHandler :: Wreq.Session -> Redis.ConnectionPool -> Psql.ConnectionPool -> ApiCtx :~> Handler+apiCtxToHandler apiClient redisPool psqlPool = NT toHandler+  where+    toHandler :: forall a. ApiCtx a -> Handler a+    toHandler a = withRedis $ withPsql $ withAPIClient a+      where+        withAPIClient m = runReaderT m apiClient+        withRedis m = runReaderT m redisPool+        withPsql m = runReaderT m psqlPool++type FetchAllImpl a = ApiCtx (Map UUID (IdAnd a))+type FetchAllAPI a = Get '[JSON] (Map UUID (IdAnd a))+type FetchImpl a = UUID -> ApiCtx (IdAnd a)+type FetchAPI a = Capture "id" UUID :> Get '[JSON] (IdAnd a)+type CreateImpl a = a -> ApiCtx (IdAnd a)+type CreateAPI a = ReqBody '[JSON] a :> Post '[JSON] (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 ReplaceImpl a = UUID -> a -> ApiCtx (IdAnd a)+type ReplaceAPI a = Capture "id" UUID :> ReqBody '[JSON] a :> Post '[JSON] (IdAnd a)++type ServerImpl a =+  (FetchAllImpl a)+  :<|> (FetchImpl a)+  :<|> (CreateImpl a)+  -- :<|> (PatchImpl a)+  :<|> (ReplaceImpl a)+type ServerAPI a =+  (FetchAllAPI a)+  :<|> (FetchAPI a)+  :<|> (CreateAPI a)+  -- :<|> (PatchAPI a)+  :<|> (ReplaceAPI a)+++class (FromJSON a, ToJSON a, Show a) => ResourceDefinition a where+  restFetchAll :: FetchAllImpl a+  restFetchAll = do+    resources <- fetchAllResources+    return $ Map.fromList $ map idAndToPair resources++  restFetch :: FetchImpl a+  restFetch uuid = do+    maybeResource <- fetchResource uuid+    case maybeResource of+      Nothing -> throwError $ err404+        { errReasonPhrase = "No resource found for id"+        , errBody = cs $ "Could not find a resource with UUID: " ++ show uuid+        }+      Just value -> return $ IdAnd (uuid, value)++  restCreate :: CreateImpl a+  restCreate a = handleDupes $ do+      maybeId <- createResource a+      case maybeId of+        (Just id) -> restFetch id+        Nothing -> throwIO $ err400+          { errReasonPhrase = "Could not create resource"+          , errBody = cs $ show a+          }++  restPatch :: PatchImpl a+  restPatch id patch = handleDupes $ do+    (IdAnd (_,original::a)) <- restFetch id+    case JSON.patch patch $ toJSON original of+      Error str -> throwError $ err400+        { errReasonPhrase = "Error applying patch"+        , errBody = cs str+        }+      Success jsonValue ->+        case JSON.eitherDecode' $ JSON.encode jsonValue of+          Left err -> throwError $ err400+            { errReasonPhrase = "Error rebuilding object after patch"+            , errBody = cs err+            }+          Right value -> restReplace id value++  restReplace :: ReplaceImpl a+  restReplace id value = handleDupes $ do+      replaceResource newValue+      restFetch id+    where+      newValue = IdAnd (id,value)++  restServer :: ServerImpl a+  restServer =+    restFetchAll+    :<|> restFetch+    :<|> restCreate+    -- :<|> 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 = throwError $ 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
@@ -0,0 +1,26 @@+module RFC.Servant.ApiDoc+  ( apiToHtml+  , apiToAscii+  , apiToSwagger+  ) where++import RFC.Prelude+import RFC.String+import RFC.Servant+import Servant.Swagger+import Data.Default (def)+import qualified Text.Markdown as MD++apiToHtml :: (HasDocs a) => Proxy a -> Html+apiToHtml = preEscapedToHtml . (MD.markdown mdSettings) . cs . markdown . docs+  where+    mdSettings = def+      { MD.msLinkNewTab = False+      , MD.msAddHeadingId = True+      }++apiToAscii :: (ConvertibleString String s, HasDocs a) => Proxy a -> s+apiToAscii = cs . markdown . docs++apiToSwagger :: (HasSwagger a) => Proxy a -> Swagger+apiToSwagger = toSwagger
+ src/RFC/String.hs view
@@ -0,0 +1,14 @@+module RFC.String+  ( module RFC.String+  , module Data.String.Conversions+  , module Data.String.Conversions.Monomorphic+  ) where++import Data.String.Conversions hiding ((<>))+import Data.String.Conversions.Monomorphic hiding (fromString, toString)++type ConvertibleString = ConvertibleStrings -- I keep forgetting to pluralize this.+type ConvertibleToSBS a = ConvertibleStrings a StrictByteString+type ConvertibleFromSBS a = ConvertibleStrings StrictByteString a++
+ src/RFC/Throttle.hs view
@@ -0,0 +1,33 @@+module RFC.Throttle+  ( createThrottle+  , withThrottle+  , Throttle+  ) where++import RFC.Prelude+import Data.Pool+import GHC.Conc (numCapabilities)++newtype Throttle = Throttle (Pool ())++createThrottle :: (MonadIO m)  => Int -> m Throttle+createThrottle maxSimultaneous = do+    let stripes = min maxSimultaneous $ log2 numCapabilities+    let perStripe = maxPerStripe stripes+    liftIO $ Throttle <$> createPool+      ioUnit+      (const ioUnit)+      stripes+      0.5+      perStripe+  where+    ioUnit = return () :: IO ()+    maxPerStripe :: Int -> Int+    maxPerStripe stripes = max 1 $ maxSimultaneous `quot` stripes+    log2 :: Int -> Int+    log2 x+      | (toInteger x) <= 2 = 1+      | otherwise = 1 + log2 (x `quot` 2)++withThrottle :: (MonadBaseControl IO m) => Throttle -> m b -> m b+withThrottle (Throttle pool) action = withResource pool (const action)
+ src/RFC/Wai.hs view
@@ -0,0 +1,54 @@+module RFC.Wai+  ( defaultMiddleware+  ) where++import RFC.Prelude+import RFC.Env (isDevelopment)+import Network.Wai+import Network.Wai.Middleware.AcceptOverride+import Network.Wai.Middleware.Approot (envFallback)+import Network.Wai.Middleware.Autohead+import Network.Wai.Middleware.Gzip+import Network.Wai.Middleware.Jsonp+import Network.Wai.Middleware.MethodOverridePost+import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)+import System.IO.Temp (getCanonicalTemporaryDirectory, createTempDirectory)+import Network.Wai.Middleware.Cors+import Network.HTTP.Types.Method+import Network.HTTP.Types.Header++defaultMiddleware :: IO Middleware+defaultMiddleware = do+  isDev <- isDevelopment+  approot <- envFallback+  tmpDir <- getCanonicalTemporaryDirectory+  gzipDir <- createTempDirectory tmpDir "wai-gzip-middleware"+  return $+    methodOverridePost .+    acceptOverride .+    (cors $ const $ Just corsConfig).+    autohead .+    jsonp .+    approot .+    gzip (gzipConfig gzipDir) .+    (if isDev then logStdoutDev else logStdout)+  where+    corsConfig = simpleCorsResourcePolicy+      { corsRequireOrigin = False+      , corsVaryOrigin = False+      , corsMaxAge = Nothing+      , corsRequestHeaders = hContentType : simpleHeaders+      , corsMethods =+        [ methodGet+        , methodPost+        , methodHead+        , methodDelete+        , methodPatch+        , methodOptions+        , methodPut+        ]+      }+    gzipConfig gzipDir = def+      { gzipFiles = GzipCacheFolder gzipDir+      , gzipCheckMime = const True+      }