ez-couch 0.6.2 → 0.7.0

raw patch · 12 files changed

+277/−116 lines, 12 filesdep +neat-interpolationdep −tlsdep ~aesondep ~classy-preludedep ~classy-prelude-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: neat-interpolation

Dependencies removed: tls

Dependency ranges changed: aeson, classy-prelude, classy-prelude-conduit, http-conduit

API changes (from Hackage documentation)

Files

• ez-couch.cabal +6/−6
• src/EZCouch.hs +15/−2
• src/EZCouch/Action.hs +9/−11
• src/EZCouch/EntityIsolation.hs +1/−2
• src/EZCouch/Isolation.hs +1/−1
• src/EZCouch/JS.hs +12/−12
• src/EZCouch/ReadAction.hs +41/−27
• src/EZCouch/Sweeper.hs +2/−2
• src/EZCouch/Types.hs +1/−3
• src/EZCouch/View.hs +187/−40
• src/Network/HTTP/Conduit/Request.hs +1/−8
• src/Util/Logging.hs +1/−2

@@ -1,5 +1,5 @@ name:               ez-couch-version:            0.6.2+version:            0.7.0 cabal-version:      >=1.8 build-type:         Simple license:            MIT@@ -49,10 +49,10 @@   build-depends:    base >= 4.5 && < 5,                     ghc-prim >= 0.2,                     time >= 1.4,-                    aeson >= 0.6,+                    aeson == 0.6.*,                     attoparsec >= 0.10,                     attoparsec-conduit >= 0.5,-                    http-conduit == 1.8.*,+                    http-conduit == 1.9.*,                     http-types >= 0.7,                     hslogger >= 1.2,                     old-locale >= 1.0,@@ -65,11 +65,11 @@                     random >= 1.0,                     resourcet >= 0.3,                     string-conversions >= 0.2,-                    classy-prelude >= 0.5.0,-                    classy-prelude-conduit,+                    classy-prelude == 0.5.*,+                    classy-prelude-conduit == 0.5.*,                     hashable >= 1.1,                     vector,-                    tls +                    neat-interpolation == 0.1.*  source-repository head   type:             git

@@ -8,13 +8,26 @@   createEntity,   createEntities,   -- ** Reading +  KeysSelection(..),   readEntities,   readRandomEntities,   readEntity,   readKeysExist,   readKeys,   readCount,-  KeysSelection(..),+  -- ** Reading functions shortcuts+  readKeys',+  readCount',+  readKeysExist',+  readEntities',+  readEntities'',+  readEntities''',+  readEntities'''',+  readEntities''''',+  readEntity',+  readEntity'',+  readEntity''',+  readEntity'''',   -- ** Updating    updateEntity,   updateEntities,@@ -28,6 +41,7 @@   -- * Working with Views   View(..),   ViewKey(..),+  Path(..),    -- * Transactions   -- | CouchDB doesn't provide a way to do traditional locking-based transactions, as it applies an Optimistic Concurrency Control strategy (<http://en.wikipedia.org/wiki/Optimistic_concurrency_control>). EZCouch approaches the issue by providing a way to easily isolate entities from being accessed by concurrent clients, which you can use to build all kinds of transactions upon.@@ -52,7 +66,6 @@   run,   runWithManager,   ConnectionSettings(..),-  defaultPort,   EZCouchException(..),    -- * Classes which records should implement

@@ -23,13 +23,11 @@ data ConnectionSettings    = ConnectionSettings {         connectionSettingsHost :: Text,-      connectionSettingsPort :: Int,+      connectionSettingsPort :: Maybe Int,       connectionSettingsAuth :: Maybe (Text, Text),       connectionSettingsDatabase :: Text     } -defaultPort = 5984 :: Int- type Environment = (ConnectionSettings, HTTP.Manager, NominalDiffTime)  -- | All EZCouch operations are performed in this monad.@@ -54,11 +52,11 @@         HTTP.method = method,         HTTP.host = encodeUtf8 host,         HTTP.requestHeaders = headers,-        HTTP.port = port,+        HTTP.port = fromMaybe 5984 port,         HTTP.path = packPath $ maybe [] (database : ) $ dbPath,         HTTP.queryString = query,         HTTP.requestBody = HTTP.RequestBodyLBS body,-        HTTP.checkStatus = \_ _ -> Nothing,+        HTTP.checkStatus = \_ _ _ -> Nothing,         HTTP.responseTimeout = Just $ 10 ^ 6 * 5       }       where@@ -125,12 +123,12 @@  processResponse :: MonadAction m   => HTTP.Response (UnparsedBody m) -> m (Response (HTTP.Response (UnparsedBody m)))-processResponse response@(HTTP.Response (HTTP.Status code msg) _ headers body) =-  case code of+processResponse response =+  case HTTP.statusCode . HTTP.responseStatus $ response of     -- Handle status 500 by extracting a possible "Not found response" or      -- throwing a ServerException otherwise-    _ | code `elem` [404, 500] -> do-      json <- body $$+- Atto.sinkParser Aeson.json+    code | code `elem` [404, 500] -> do+      json <- HTTP.responseBody response $$+- Atto.sinkParser Aeson.json       case Aeson.fromJSON json of         Aeson.Success (Error.Error "error" (Just reason) _)           | isPrefixOf "{{try_clause,{not_found,missing}}" reason @@ -141,6 +139,6 @@           throwIO $ ServerException $ "Status " ++ show code ++ " response: " ++ (decodeUtf8 . toStrict . Aeson.encode) json         Aeson.Error m ->            throwIO $ ServerException $ "Status " ++ show code-    _ | code >= 400 ->-      crash $ "Unexpected status code: " ++ show code ++ ", " ++ (decodeUtf8) msg+    code | code >= 400 ->+      crash $ "Unexpected status code: " ++ show code ++ ", " ++ (decodeUtf8 . HTTP.statusMessage . HTTP.responseStatus $ response)     _ -> return $ ResponseOk response

@@ -109,6 +109,5 @@ deleteIsolations :: (MonadAction m, Entity e)   => [Isolation e]   -> m ()-deleteIsolations = -  void . tryOperation . deleteEntitiesByIdRevs . map isolationIdRev+deleteIsolations = deleteEntitiesByIdRevs . map isolationIdRev 

@@ -25,7 +25,7 @@   result <- try $ createIdentifiedEntity (id', Isolation time)   case result of     Left (OperationException _) -> do-      isolation <- readEntity ViewById (KeysSelectionList [id']) 0 False+      isolation <- readEntity 0 False (KeysSelectionList [id']) ViewById       case isolation of         Just isolation -> do           if (Isolation.since . persistedValue) isolation < Time.addUTCTime (negate $ fromIntegral timeout) time

@@ -13,59 +13,59 @@ instance (ToJS a, ToJS b) =>    ToJS (a, b)    where-    toJS (a, b) = "[" +    toJS (a, b) = "[ "        ++ toJS a ++ ", " -      ++ toJS b ++ "]"+      ++ toJS b ++ " ]"  instance (ToJS a, ToJS b, ToJS c) =>    ToJS (a, b, c)    where-    toJS (a, b, c) = "[" +    toJS (a, b, c) = "[ "        ++ toJS a ++ ", "        ++ toJS b ++ ", " -      ++ toJS c ++ "]"+      ++ toJS c ++ " ]"  instance (ToJS a, ToJS b, ToJS c, ToJS d) =>    ToJS (a, b, c, d)    where-    toJS (a, b, c, d) = "[" +    toJS (a, b, c, d) = "[ "        ++ toJS a ++ ", "        ++ toJS b ++ ", "        ++ toJS c ++ ", " -      ++ toJS d ++ "]"+      ++ toJS d ++ " ]"  instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e) =>    ToJS (a, b, c, d, e)    where-    toJS (a, b, c, d, e) = "[" +    toJS (a, b, c, d, e) = "[ "        ++ toJS a ++ ", "        ++ toJS b ++ ", "        ++ toJS c ++ ", "        ++ toJS d ++ ", " -      ++ toJS e ++ "]"+      ++ toJS e ++ " ]"  instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e, ToJS f) =>    ToJS (a, b, c, d, e, f)    where-    toJS (a, b, c, d, e, f) = "[" +    toJS (a, b, c, d, e, f) = "[ "        ++ toJS a ++ ", "        ++ toJS b ++ ", "        ++ toJS c ++ ", "        ++ toJS d ++ ", "        ++ toJS e ++ ", " -      ++ toJS f ++ "]"+      ++ toJS f ++ " ]"  instance (ToJS a, ToJS b, ToJS c, ToJS d, ToJS e, ToJS f, ToJS g) =>    ToJS (a, b, c, d, e, f, g)    where-    toJS (a, b, c, d, e, f, g) = "[" +    toJS (a, b, c, d, e, f, g) = "[ "        ++ toJS a ++ ", "        ++ toJS b ++ ", "        ++ toJS c ++ ", "        ++ toJS d ++ ", "        ++ toJS e ++ ", "        ++ toJS f ++ ", "-      ++ toJS g ++ "]"+      ++ toJS g ++ " ]"   newtype JSON a = JSON a

@@ -29,19 +29,19 @@   readAction :: (MonadAction m, Entity a, ToJSON k)-  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode+  => Bool -- ^ Include docs   -> Int -- ^ Skip   -> Maybe Int -- ^ Limit   -> Bool -- ^ Descending-  -> Bool -- ^ Include docs+  -> KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m Value -- ^ An unparsed response body JSON-readAction view mode skip limit desc includeDocs = do+readAction includeDocs skip limit desc mode view = do   result <- action path qps body    case result of     ResponseNotFound -> do       logLn 2 $ "View " -        ++ fromMaybe (crash "Unnamed view") (viewGeneratedName view) +        ++ fromMaybe undefined (viewGeneratedName view)          ++ " does not exist. Generating."       createOrUpdateView view        action path qps body >>= \r -> case r of@@ -89,46 +89,46 @@   readKeys :: (MonadAction m, Entity a, ToJSON k, FromJSON k) -  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode+  => KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m [k] -readKeys view mode = fmap (map fst . filter snd) $ readKeysExist view mode+readKeys mode view = fmap (map fst . filter snd) $ readKeysExist mode view  readCount :: (MonadAction m, Entity a, ToJSON k, FromJSON k)-  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode+  => KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m Int-readCount view mode = fmap length $ readKeys view mode+readCount mode view = fmap length $ readKeys mode view  readKeysExist :: (MonadAction m, Entity a, ToJSON k, FromJSON k) -  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode+  => KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m [(k, Bool)]    -- ^ An associative list of `Bool` values by keys designating the existance of appropriate entities-readKeysExist view mode =-  readAction view mode 0 Nothing False False+readKeysExist mode view =+  readAction False 0 Nothing False mode view     >>= runParser (rowsParser1 >=> mapM keyExistsParser . toList)   readEntities :: (MonadAction m, Entity a, ToJSON k)-  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode-  -> Int -- ^ Skip+  => Int -- ^ Skip   -> Maybe Int -- ^ Limit   -> Bool -- ^ Descending+  -> KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m [Persisted a]-readEntities view mode skip limit desc =-  readAction view mode skip limit desc True+readEntities skip limit desc mode view =+  readAction True skip limit desc mode view     >>= runParser (rowsParser1 >=> mapM persistedParser . toList)      >>= return . catMaybes  readEntity :: (MonadAction m, Entity a, ToJSON k)-  => View a k -- ^ View-  -> KeysSelection k -- ^ Keys selection mode-  -> Int -- ^ Skip+  => Int -- ^ Skip   -> Bool -- ^ Descending+  -> KeysSelection k -- ^ Keys selection mode+  -> View a k -- ^ View   -> m (Maybe (Persisted a))-readEntity view mode skip desc = -  listToMaybe <$> readEntities view mode skip (Just 1) desc+readEntity skip desc mode view = +  listToMaybe <$> readEntities skip (Just 1) desc mode view  readRandomEntities :: (MonadAction m, Entity a)    => Maybe Int -- ^ Limit@@ -136,9 +136,23 @@ readRandomEntities limit = do   startKey :: Double <- liftIO $ Random.randomRIO (0.0, 1.0)   readEntities -    (ViewByKeys1 ViewKeyRandom) -    (KeysSelectionRangeStart startKey)     0     limit     False+    (KeysSelectionRangeStart startKey)+    (ViewByKeys1 ViewKeyFloatRevHash)  ++-- * Versions with defaults:+readKeys' = readKeys KeysSelectionAll+readCount' = readCount KeysSelectionAll+readKeysExist' = readKeysExist KeysSelectionAll+readEntities' = readEntities 0+readEntities'' = readEntities 0 Nothing+readEntities''' = readEntities 0 Nothing False+readEntities'''' = readEntities 0 Nothing False KeysSelectionAll+readEntities''''' = readEntities 0 Nothing False KeysSelectionAll ViewById+readEntity' = readEntity 0+readEntity'' = readEntity 0 False+readEntity''' = readEntity 0 False KeysSelectionAll+readEntity'''' = readEntity 0 False KeysSelectionAll ViewById

@@ -31,11 +31,11 @@ readZombieEntityIsolations = do   now <- readTime   readEntities-    (ViewByKeys1 (ViewKeyField "till"))-    (KeysSelectionRangeEnd now)     0     Nothing     False+    (KeysSelectionRangeEnd now)+    (ViewByKeys1 (ViewKeyValue $ PathField "till" PathNil))  releaseIsolations isolations = do   logLn 1 $ "Sweeping " ++ show (length isolations) ++ " isolations"

@@ -8,7 +8,6 @@ import Data.Aeson import GHC.Generics import EZCouch.Entity-import EZCouch.Crash  -- | A wrapper for entity values which preserves the information required for -- identifying the appropriate documents in the db.@@ -25,8 +24,7 @@  persistedIdHashPart :: Entity a => Persisted a -> Text persistedIdHashPart (Persisted id _ value) = -  fromMaybe (crash $ "Unexpected id: " ++ show id) $ -    stripPrefix (entityType value ++ "-") id+  fromMaybe undefined $ stripPrefix (entityType value ++ "-") id   type Identified a = (Text, a)

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric, GADTs, StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, FlexibleContexts, MultiParamTypeClasses, ScopedTypeVariables, DeriveDataTypeable, DeriveGeneric, GADTs, StandaloneDeriving, QuasiQuotes #-} module EZCouch.View where  import Prelude ()@@ -10,7 +10,6 @@ import EZCouch.Types import EZCouch.Design  import EZCouch.WriteAction-import EZCouch.Crash import qualified Control.Monad as Monad import qualified Data.Foldable as Foldable import qualified EZCouch.Model.Design as DesignModel@@ -18,34 +17,53 @@ import qualified EZCouch.Base62 as Base62 import Data.Hashable  import EZCouch.JS+import NeatInterpolation + type ViewModel = ViewModel.View type DesignModel = DesignModel.Design +data Path = +  PathField Text Path |+  PathItem Path |+  PathNil+  deriving (Show, Eq) +pathJS :: Path -> Text -> Text+pathJS (PathNil) js = js+pathJS (PathField name tail) js =+  pathJS tail $ +    [text|+      $js+        .map( function( it ){ return it.$name } )+    |]+pathJS (PathItem tail) js =+  pathJS tail $ +    [text|+      join( +        $js+      )+    |]+ data ViewKey a = -  ViewKeyField Text |+  ViewKeyValue Path |   -- ^ A path to a field value.-  -- -  -- Assuming the following record declarations:-  -- -  -- > data A = A { b :: B }-  -- > data B = B { c :: Int }-  -- -  -- A path value of @\"b.c\"@ will emit the values of the @c@ field of a JSON -  -- object representing the record @B@ in a view key of type @ViewKey A@.+  ViewKeyFloatRevHash+  -- ^ A floating point number in range @0 <= x <= 1@ based on the revision+  -- hash of the document.    -- -  -- Yes, it's not static. But it's probably the only place in the library that -  -- the compiler doesn't check for you.-  ViewKeyRandom-  -- ^ This will emit a JavaScript @Math.random()@ value as a key. This is what -  -- makes the querying for random entities possible.+  -- This is used to simulate an output @Math.random()@ for random fetching, +  -- while producing a stable value across all database replicas.   deriving (Show, Eq) - instance ToJS (ViewKey a) where-  toJS (ViewKeyField field) = "doc." ++ field-  toJS ViewKeyRandom = "Math.random()"+  toJS (ViewKeyValue path) = pathJS path "[ doc ]"+  toJS ViewKeyFloatRevHash = [text|+    [ +      parseInt( doc._rev.split("-", 2)[1], 16 ) / 3.402823669209385e+38+    ]+  |]+ instance Hashable (ViewKey a) where   hashWithSalt salt = hashWithSalt salt . toJS @@ -121,30 +139,11 @@ viewDesignName ViewById = Nothing viewDesignName view = entityType . (undefined :: View a k -> a) <$> Just view -viewKeysJS view = case view of-  ViewById -> Nothing-  ViewByKeys1 a -> Just $ toJS a-  ViewByKeys2 a b -> Just $ toJS (a, b)-  ViewByKeys3 a b c -> Just $ toJS (a, b, c)-  ViewByKeys4 a b c d -> Just $ toJS (a, b, c, d)-  ViewByKeys5 a b c d e -> Just $ toJS (a, b, c, d, e)-  ViewByKeys6 a b c d e f -> Just $ toJS (a, b, c, d, e, f)-  ViewByKeys7 a b c d e f g -> Just $ toJS (a, b, c, d, e, f, g)--viewMapFunctionJS :: (Entity a) => View a k -> Maybe Text-viewMapFunctionJS view = fmap concat $ sequence [-    pure "function (doc) { if (doc._id.lastIndexOf('",-    viewDesignName view,-    pure "-') == 0) emit(",-    viewKeysJS view,-    pure ", null) }"-  ]- viewPath :: (Entity a) => View a k -> [Text] viewPath view = case view of   ViewById -> ["_all_docs"]-  _ -> ["_design", fromMaybe (crash "No view design") $ viewDesignName view, -        "_view", fromMaybe (crash "No view name") $ viewGeneratedName view]+  _ -> ["_design", fromMaybe undefined $ viewDesignName view, +        "_view", fromMaybe undefined $ viewGeneratedName view]  createOrUpdateView :: (MonadAction m, Entity a)    => View a k @@ -154,3 +153,151 @@     Just model <- ViewModel.View <$> viewMapFunctionJS view <*> pure Nothing     = createOrUpdateDesignView name model   | otherwise = error "EZCouch.View.createOrUpdateView: Attempt to persist a view which does not support it"++viewKeysJS :: Entity a => View a k -> Maybe Text+viewKeysJS view = case view of+  ViewById -> Nothing+  ViewByKeys1 a -> Just $ toJS a+  ViewByKeys2 a b -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+    in +      [text| +        combinations([ +          $aJS, +          $bJS +        ])+      |]+  ViewByKeys3 a b c -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+      cJS = toJS c+    in +      [text| +        combinations([ +          $aJS, +          $bJS, +          $cJS +        ])+      |]+  ViewByKeys4 a b c d -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+      cJS = toJS c+      dJS = toJS d+    in +      [text| +        combinations([ +          $aJS, +          $bJS, +          $cJS, +          $dJS +        ])+      |]+  ViewByKeys5 a b c d e -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+      cJS = toJS c+      dJS = toJS d+      eJS = toJS e+    in +      [text| +        combinations([ +          $aJS, +          $bJS, +          $cJS, +          $dJS, +          $eJS +        ])+      |]+  ViewByKeys6 a b c d e f -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+      cJS = toJS c+      dJS = toJS d+      eJS = toJS e+      fJS = toJS f+    in +      [text| +        combinations([ +          $aJS, +          $bJS, +          $cJS, +          $dJS, +          $eJS, +          $fJS +        ])+      |]+  ViewByKeys7 a b c d e f g -> Just $ +    let +      aJS = toJS a+      bJS = toJS b+      cJS = toJS c+      dJS = toJS d+      eJS = toJS e+      fJS = toJS f+      gJS = toJS g+    in +      [text| +        combinations([ +          $aJS, +          $bJS, +          $cJS, +          $dJS, +          $eJS, +          $fJS, +          $gJS +        ])+      |]+++viewMapFunctionJS :: (Entity a) => View a k -> Maybe Text+viewMapFunctionJS view = +  mapFunctionJS <$> viewDesignName view <*> viewKeysJS view++mapFunctionJS :: Text -> Text -> Text+mapFunctionJS designName expr = +  [text|+    function( doc ){+      function startsWith( start, string ){+        return string.lastIndexOf( start ) == 0+      }+      function join( it ){ +        return [].concat.apply( [], it ) +      }+      function tail( array ){ +        return array.slice(1)+      }+      function cons( head, array ){ +        return [ head ].concat(array) +      }+      function combinations( arrays ){+        if( arrays.length == 0 ) return []+        else if( arrays.length == 1 ) return arrays[0]+        else return join( +          arrays[0].map( function( it ){ +            return combinations( tail( arrays ) ).map( function( row ){+              return cons( it, row )+            } )+          } )+        )+      }+      function zip( arrays ){+        return arrays[0].map( function( _, i ){+          return arrays.map( function( array ){ return array[i] } )+        } )+      }++      if( startsWith( '$designName-', doc._id ) ){+        $expr+          .forEach( function( row ){ +            emit( row, null ) +          } )+      }+    }+  |]

@@ -5,7 +5,6 @@ import ClassyPrelude import Network.HTTP.Conduit import Network.HTTP.Types-import qualified Network.TLS as TLS  withHeader (name, value) request   = request { requestHeaders = headers' }@@ -42,15 +41,9 @@   = request { responseTimeout = timeout }    fixedHTTP request manager -  = flip catch handleTLSHandshakeFailed $-      flip catch handleIOException $-        http request manager+  = http request manager `catch` handleIOException   where     handleIOException (e :: IOException) = throwIO -      $ FailedConnectionException -          (unpack $ decodeUtf8 $ host request) -          (port request)-    handleTLSHandshakeFailed (e :: TLS.HandshakeFailed) = throwIO        $ FailedConnectionException            (unpack $ decodeUtf8 $ host request)            (port request)

@@ -43,8 +43,7 @@   6 -> ALERT   x | x >= 7 -> EMERGENCY -priorityLevel p = fromMaybe fail $ find ((==) p . levelPriority) [0..7]-  where fail = error $ "Unexpected priority " ++ show p+priorityLevel p = fromMaybe undefined $ find ((==) p . levelPriority) [0..7]  formatter format h (prio, msg) loggername    = replaceVarM