rfc 0.0.0.15 → 0.0.0.16

raw patch · 3 files changed

+74/−27 lines, 3 filesdep +bifunctorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bifunctors

API changes (from Hackage documentation)

Files

• rfc.cabal +2/−1
• src/RFC/Data/IdAnd.hs +64/−19
• src/RFC/Servant.hs +8/−7

@@ -1,5 +1,5 @@ name:                rfc-version:             0.0.0.15+version:             0.0.0.16 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@@ -54,6 +54,7 @@                      , vector                      , lifted-async                      , text+                     , bifunctors   if flag(Browser)     build-depends:     aeson                      , attoparsec

@@ -1,12 +1,13 @@-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE DeriveGeneric       #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE NoImplicitPrelude   #-}-{-# LANGUAGE OverloadedLists     #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE OverloadedLists            #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}   module RFC.Data.IdAnd@@ -16,19 +17,29 @@   , idAndToTuple   , tupleToIdAnd   , idAndToPair+  , RefMap(..)   ) where  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 +#if MIN_VERSION_aeson(1,0,0)+  -- Don't need the backflips for maps+#else+import           Data.Aeson.Types                     (Parser, typeMismatch)+import           Data.Bitraversable+import qualified Data.HashMap.Lazy                    as HashMap+#endif+ #ifndef GHCJS_BROWSER import           Control.Lens                         hiding ((.=))-import           Data.Aeson                           as JSON import           Data.Proxy                           (Proxy (..)) import           Data.Swagger-import           Data.UUID.Types                      as UUID import           Database.PostgreSQL.Simple.FromField () import           Database.PostgreSQL.Simple.FromRow import           Database.PostgreSQL.Simple.ToField@@ -40,6 +51,9 @@ newtype IdAnd a = IdAnd (UUID, a)   deriving (Eq, Ord, Show, Generic, Typeable) +newtype RefMap a = RefMap (Map.Map UUID (IdAnd a))+  deriving (Eq, Ord, Show, Generic, Typeable, FromJSON, ToJSON)+ tupleToIdAnd :: (UUID, a) -> IdAnd a tupleToIdAnd = IdAnd @@ -52,10 +66,9 @@ 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+idAndsToMap :: [IdAnd a] -> RefMap a+idAndsToMap list = RefMap $ Map.fromList $ List.map (\idAnd@(IdAnd(uuid,_)) -> (uuid,idAnd)) list -#ifndef GHCJS_BROWSER instance (FromJSON a) => FromJSON (IdAnd a) where   parseJSON = JSON.withObject "IdAnd" $ \o -> do     id <- o .: "id"@@ -65,6 +78,38 @@ instance (ToJSON a) => ToJSON (IdAnd a) where   toJSON (IdAnd (id,value)) = object [ "id".=id, "value".=value ] +#if MIN_VERSION_aeson(1,0,0)+  -- Have Mpa instances automatically created+#else+instance (FromJSON a) => FromJSON (Map UUID (IdAnd a)) where+  parseJSON (Object obj) =+      Map.fromList <$> listInParser+    where+      objList :: [(Text, Value)]+      objList = HashMap.toList obj+      die :: Text -> Parser UUID+      die k = fail . cs $ "Could not parse UUID: " ++ k+      mapMKey :: Text -> Parser UUID+      mapMKey k = maybe (die k) return $ UUID.fromText k+      mapMVal :: Value -> Parser (IdAnd a)+      mapMVal = parseJSON+      mapPair :: (Text,Value) -> Parser (UUID, IdAnd a)+      mapPair = bimapM mapMKey mapMVal+      parserList :: [Parser (UUID, IdAnd a)]+      parserList = map mapPair objList+      listInParser :: Parser [(UUID, IdAnd a)]+      listInParser = sequence parserList++  parseJSON invalid = typeMismatch "Map UUID (IdAnd a)" invalid+++instance (ToJSON a) => ToJSON (Map UUID (IdAnd a)) where+  toJSON =+    Object . HashMap.fromList . map (\(k,v) -> (UUID.toText k, toJSON v)) . Map.toList++#endif++#ifndef GHCJS_BROWSER instance (FromRow a) => FromRow (IdAnd a) where   fromRow = valuesToIdAnd <$> field <*> fromRow @@ -85,13 +130,13 @@         & required .~ ["id", "value"]         & example .~ (toJSON . snd <$> maybeSample) -instance (ToSchema a, ToJSON a, ToSample a) => ToSchema (Map UUID (IdAnd a)) where+instance (ToSchema a, ToJSON a, ToSample a) => ToSchema (RefMap a) where   declareNamedSchema _ = do     NamedSchema{..} <- declareNamedSchema (Proxy :: Proxy a)     let aMaybeName =  _namedSchemaName     idAndASchema <- declareSchemaRef (Proxy :: Proxy (IdAnd a))-    let maybeSample = safeHead $ toSamples (Proxy :: Proxy (Map UUID (IdAnd a)))-    return $ NamedSchema (map (\name -> "Map of IdAnd " ++ name) aMaybeName) $+    let maybeSample = safeHead $ toSamples (Proxy :: Proxy (RefMap a))+    return $ NamedSchema (map (\name -> "RefMap " ++ name) aMaybeName) $       mempty         & type_ .~ SwaggerObject         & additionalProperties .~ (Just idAndASchema)@@ -207,9 +252,9 @@     where       idAndify (uuid, (desc, a)) = (desc, IdAnd (uuid,a)) -instance (ToSample a) => ToSample (Map UUID (IdAnd a)) where+instance (ToSample a) => ToSample (RefMap a) where   toSamples _ = singleSample $-      Map.fromList $ map idAndify $ zip uuidList (toSamples Proxy)+      RefMap $ Map.fromList $ map idAndify $ zip uuidList (toSamples Proxy)     where       idAndify (uuid, (_, a)) = (uuid, IdAnd (uuid,a)) 

@@ -21,14 +21,15 @@   , module Text.Blaze.Html   , module Data.Swagger   , module RFC.Data.IdAnd+  , module RFC.API   ) where  import           Data.Aeson                 as JSON import qualified Data.Aeson.Diff            as JSON-import qualified Data.Map.Strict            as Map import           Data.Swagger               (Swagger, ToSchema) import           Database.PostgreSQL.Simple (SqlError (..)) import           Network.Wreq.Session       as Wreq+import           RFC.API import           RFC.Data.IdAnd import           RFC.HTTP.Client import           RFC.JSON                   ()@@ -69,16 +70,16 @@         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 FetchAllImpl a = ApiCtx (RefMap a)+type FetchAllAPI a = JGet (RefMap a) type FetchImpl a = UUID -> ApiCtx (IdAnd a)-type FetchAPI a = Capture "id" UUID :> Get '[JSON] (IdAnd a)+type FetchAPI a = Capture "id" UUID :> JGet (IdAnd a) type CreateImpl a = a -> ApiCtx (IdAnd a)-type CreateAPI a = ReqBody '[JSON] a :> Post '[JSON] (IdAnd a)+type CreateAPI a = JReqBody a :> JPost (IdAnd a) type PatchImpl a = UUID -> JSON.Patch -> ApiCtx (IdAnd a) -- type PatchAPI a = Capture "id" UUID :> ReqBody '[JSON] JSON.Patch :> Patch '[JSON] (IdAnd a) type ReplaceImpl a = UUID -> a -> ApiCtx (IdAnd a)-type ReplaceAPI a = Capture "id" UUID :> ReqBody '[JSON] a :> Post '[JSON] (IdAnd a)+type ReplaceAPI a = Capture "id" UUID :> JReqBody a :> JPost (IdAnd a)  type ServerImpl a =   (FetchAllImpl a)@@ -98,7 +99,7 @@   restFetchAll :: FetchAllImpl a   restFetchAll = do     resources <- fetchAllResources-    return $ Map.fromList $ map idAndToPair resources+    return $ idAndsToMap resources    restFetch :: FetchImpl a   restFetch uuid = do