packages feed

JunkDB (empty) → 0.1.0.0

raw patch · 6 files changed

+276/−0 lines, 6 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, conduit, data-default, directory, filepath, mtl, network, resourcet

Files

+ Database/Junk/FileSystem.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings,TypeFamilies,MultiParamTypeClasses,FlexibleInstances #-}+module Database.Junk.FileSystem (+  FileSystemKVS (..)+  ) where++import Control.Monad.Trans (lift)+import qualified Data.ByteString as BS+import System.FilePath+import System.Directory+import Data.Conduit (yield, ($=))+import qualified Data.Conduit.List as C (concatMapM,mapM,filter)++import Database.KVS++newtype FileSystemKVS+  = FileSystemKVS {+    fsBasePath :: FilePath+    }++instance KVS FileSystemKVS IO FilePath BS.ByteString where+  insert (FileSystemKVS dir) k = BS.writeFile (dir </> k)+  accept (FileSystemKVS dir) k f g = do+    b <- doesFileExist (dir </> k)+    if b +      then f+      else BS.readFile (dir </> k) >>= g+  delete (FileSystemKVS dir) k = removeFile (dir </> k) >> return (Just True)++instance EnumeratableKVS FileSystemKVS IO FilePath BS.ByteString where+  elemsWithKey c@(FileSystemKVS dir) = +    keys c $= C.mapM (\x -> do+                         y <- lift $ BS.readFile (dir </> x)+                         return (x,y))+  keys (FileSystemKVS dir) =+    yield dir +    $= C.concatMapM (lift . getDirectoryContents)+    $= C.filter (not . flip elem [".",".."])++instance WipableKVS (FileSystemKVS) IO where+  wipe (FileSystemKVS dir) =+    getDirectoryContents dir >>= mapM_ (removeFile . (dir </>))
+ Database/Junk/Memcached.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies, RankNTypes,TypeSynonymInstances, MultiParamTypeClasses,FlexibleInstances,RecordWildCards,ViewPatterns,LambdaCase #-}+module Database.Junk.Memcached (connect, disconnect, Memcached (..)) where++import Control.Applicative+import qualified Data.ByteString.Char8 as BS+import qualified Network as N+import System.IO (Handle, hClose,hFlush)++import Database.KVS++data Memcached = Memcached { mcdServer :: Handle, mcdExpires :: Int, mcdFlags :: Int }++connect :: N.HostName -> N.PortNumber -> Int -> Int -> IO Memcached+connect hn pn expires flags= do+  h <- N.connectTo hn (N.PortNumber pn)+  return $ Memcached h expires flags++disconnect :: Memcached -> IO ()+disconnect = hClose . mcdServer++instance KVS Memcached IO BS.ByteString BS.ByteString where+  insert (Memcached {..}) k v =+    mapM_ (BS.hPut mcdServer) ["set ", k, " " , BS.pack $ show mcdFlags, " ", BS.pack $ show mcdFlags, " ", BS.pack $ show (BS.length v), "\r\n", v, "\r\n"]+    <* BS.hGetLine mcdServer+  accept (Memcached {..}) k f g = do+    mapM_ (BS.hPut mcdServer) ["get ", k, "\r\n"]+    hFlush mcdServer+    BS.words <$> BS.hGetLine mcdServer >>= \case+      ["VALUE", _,_, read . BS.unpack -> n] -> BS.hGet mcdServer n <* BS.hGetLine mcdServer <* BS.hGetLine mcdServer >>= g+      _ -> f+  delete (Memcached {..}) k = do+    mapM_ (BS.hPut mcdServer) ["delete ", k, " 0"]+    hFlush mcdServer+    BS.hGetLine mcdServer >>= return . Just . (== "DELETED\r")
+ Database/KVS.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE TypeFamilies, RecordWildCards, RankNTypes, MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,DefaultSignatures,GADTs,UnicodeSyntax,OverloadedStrings #-}+module Database.KVS (+  KVS (..), EnumeratableKVS(..), WipableKVS (..),+  BucketKVS(..), WrappedKVS,+  lookupWithDefault,+  wrap, wrapBinary, wrapShow, wrapJSON) where++import Prelude hiding(lookup)++import Control.Monad.Trans (lift)+import Control.Monad.Trans.Resource+import Data.Maybe (fromJust, fromMaybe)+import Data.Default+import qualified Data.ByteString.Lazy as LBS (ByteString,append)+import qualified Data.ByteString.Char8 as BS8 (ByteString,pack,unpack)+import qualified Data.Binary as BIN (Binary, encode, decode)+import Data.Conduit (Source, ($=), await, yield)+import qualified Data.Conduit.List as C (map)++import qualified Data.Aeson as AE (ToJSON, encode, FromJSON, decode)++++{-++-}+class (Monad s) => KVS c s k v | c -> s, c -> k, c -> v where+  insert :: c -> k -> v -> s ()+  +  lookup :: c -> k -> s (Maybe v)+  lookup c k = accept c k (return Nothing) (return . Just)+  +  -- | Delete specified key-value pair from container.+  delete :: c                   -- ^ Container+            -> k                -- ^ Key+            -> s (Maybe Bool)   -- ^ success, failed or unknown++  -- | Lookup value+  accept :: c                   -- ^ Container+            -> k                -- ^ Key+            -> s b              -- ^ Action for key not found+            -> (v -> s b)       -- ^ Action for key found (with Lock)+            -> s b+  +class Monad s => EnumeratableKVS c s k v | c -> s, c -> k, c-> v where+  keys :: c -> Source (ResourceT s) k+  keys c = elemsWithKey c $= C.map fst+  elems :: c -> Source (ResourceT s) v+  elems c = elemsWithKey c $= C.map snd+  elemsWithKey :: c -> Source (ResourceT s) (k,v)+  default elemsWithKey :: KVS c s k v => c -> Source (ResourceT s) (k,v)+  elemsWithKey c = keys c $= go where+    go = do +      k <- await+      case k of+        Nothing -> return ()+        Just k' -> do+          v <- lift $ lift $ lookup c k'+          case v of+            Nothing -> go+            Just v' -> yield (k',v') >> go++class (Monad s) => WipableKVS c s | c -> s where+  wipe :: c -> s ()++++lookupWithDefault :: (Monad s, Default v, KVS c s k v) => c -> k -> s v+lookupWithDefault c k = lookup c k >>= return . fromMaybe def+{-# INLINE lookupWithDefault #-}  +++{-+-}+data BucketKVS c s v where+  BucketKVS :: KVS c s LBS.ByteString v ⇒ LBS.ByteString → c → BucketKVS c s v++wrapNamespace ∷ LBS.ByteString → LBS.ByteString → LBS.ByteString+wrapNamespace ns k = ns `LBS.append` "::" `LBS.append` k+++instance Monad s ⇒ KVS (BucketKVS c s v) s LBS.ByteString v where+  insert (BucketKVS b x) k v = insert x (wrapNamespace b k) v+  delete (BucketKVS b x) = delete x . wrapNamespace b+  accept (BucketKVS b x) = accept x . wrapNamespace b++instance (Monad s,WipableKVS c s) ⇒ WipableKVS (BucketKVS c s v) s where+  wipe (BucketKVS _ x) = wipe x+--instance (Monad s, EnumeratableKVS c s k v) ⇒ EnumeratableKVS (BucketKVS c s k) s k v where -- キーからプレフィックスを剥がすのが面倒いですよ+  +  ++{-+-}+data WrappedKVS c k' v' (s :: * -> *) k v+  = WrappedKVS {+    fk :: k -> k',+    fk' :: k' -> k,+    fv :: v -> v',+    fv' :: v' -> v,+    wrapped :: c +  }++instance (KVS c s k' v', Monad s) => KVS (WrappedKVS c k' v' s k v) s k v where+  insert (WrappedKVS {..}) k v = insert wrapped (fk k) (fv v)+  lookup (WrappedKVS {..}) k =+    lookup wrapped (fk k) >>= return . maybe Nothing (Just . fv')+  delete (WrappedKVS {..}) = delete wrapped . fk+  accept (WrappedKVS {..}) k f g = accept wrapped (fk k) f (g . fv')++instance (Monad s, WipableKVS c s) => WipableKVS (WrappedKVS c k' v' s k v) s where+  wipe (WrappedKVS {..}) = wipe wrapped+  +instance (Monad s, EnumeratableKVS c s k' v') => EnumeratableKVS (WrappedKVS c k' v' s k v) s k v where+  elems (WrappedKVS {..}) = elems wrapped $= C.map fv'+  elemsWithKey (WrappedKVS {..}) = elemsWithKey wrapped $= C.map (\(x,y) -> (fk' x, fv' y))+  ++wrap :: KVS a s k' v' => (k -> k') -> (k' -> k) -> (v -> v') -> (v' -> v) -> a -> WrappedKVS a k' v' s k v+wrap = WrappedKVS++wrapBinary :: (KVS a s LBS.ByteString LBS.ByteString, BIN.Binary k, BIN.Binary v) => a -> WrappedKVS a LBS.ByteString LBS.ByteString s k v+wrapBinary = WrappedKVS BIN.encode BIN.decode BIN.encode BIN.decode++wrapShow :: (KVS a s LBS.ByteString LBS.ByteString, Show k, Show v, Read k, Read v) => a -> WrappedKVS a BS8.ByteString BS8.ByteString s k v+wrapShow = WrappedKVS (BS8.pack . show) (read . BS8.unpack) (BS8.pack . show) (read . BS8.unpack)++wrapJSON :: (KVS a s LBS.ByteString LBS.ByteString, AE.FromJSON k, AE.ToJSON k, AE.FromJSON v, AE.ToJSON v) => a -> WrappedKVS a LBS.ByteString LBS.ByteString s k v+wrapJSON = WrappedKVS AE.encode (fromJust . AE.decode) AE.encode (fromJust . AE.decode)+++
+ JunkDB.cabal view
@@ -0,0 +1,37 @@+-- Initial JunkDB.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                JunkDB+version:             0.1.0.0+-- synopsis:            +description:         Generic KVS API+license:             BSD3+license-file:        LICENSE+author:              HATTORI, Hiroki+maintainer:          seagull.kamome@gmail.com+-- copyright:           +category:            Database+build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type:                git+  location:            https://github.com/seagull-kamome/JunkDB++library+  exposed-modules:     Database.KVS,+                       Database.Junk.FileSystem,+                       Database.Junk.Memcached+  ghc-options:         -Wall+  -- other-modules:       +  build-depends:       base ==4.6.*,+                       network,+                       mtl ==2.1.*,+                       data-default ==0.4.*,+                       directory ==1.2.*,+                       filepath ==1.3.*,+                       bytestring ==0.10.*,+                       binary ==0.5.*,+                       conduit ==1.0.*,+                       aeson ==0.6.*,+                       resourcet ==0.4.*
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, HATTORI, Hiroki++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 HATTORI, Hiroki 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain