packages feed

selda-sqlite 0.1.6.1 → 0.1.7.0

raw patch · 3 files changed

+216/−34 lines, 3 filesdep +bytestringdep +timedep +uuid-typesdep ~basedep ~selda

Dependencies added: bytestring, time, uuid-types

Dependency ranges changed: base, selda

Files

selda-sqlite.cabal view
@@ -1,7 +1,8 @@ name:                selda-sqlite-version:             0.1.6.1+version:             0.1.7.0 synopsis:            SQLite backend for the Selda database EDSL.-description:         SQLite backend for the Selda database EDSL.+description:         Allows the Selda database EDSL to be used with SQLite+                     databases. homepage:            https://github.com/valderman/selda license:             MIT license-file:        LICENSE@@ -18,18 +19,23 @@ library   exposed-modules:     Database.Selda.SQLite+  other-modules:+    Database.Selda.SQLite.Parser   other-extensions:     GADTs     CPP   build-depends:-      base          >=4.8     && <5-    , exceptions    >=0.8     && <0.11-    , selda         >=0.3.0.0 && <0.4-    , text          >=1.0     && <1.3+      base          >=4.9 && <5+    , selda         >=0.4 && <0.5+    , text          >=1.0 && <1.3   if !flag(haste)     build-depends:-        direct-sqlite >=2.2   && <2.4+        bytestring    >=0.10  && <0.11+      , direct-sqlite >=2.2   && <2.4       , directory     >=1.2.2 && <1.4+      , exceptions    >=0.8 && <0.11+      , time          >=1.5   && <1.10+      , uuid-types    >=1.0   && <1.1   hs-source-dirs:     src   default-language:
src/Database/Selda/SQLite.hs view
@@ -1,25 +1,37 @@ {-# LANGUAGE GADTs, CPP, OverloadedStrings #-} -- | SQLite3 backend for Selda.-module Database.Selda.SQLite (withSQLite, sqliteOpen, seldaClose) where+module Database.Selda.SQLite+  ( SQLite+  , withSQLite+  , sqliteOpen, seldaClose+  , sqliteBackend+  ) where import Database.Selda import Database.Selda.Backend-import Data.Dynamic-import Data.Text as Text (pack, toLower, take, isSuffixOf)+import Database.Selda.SQLite.Parser+import Data.Maybe (fromJust)+#ifndef __HASTE__ import Control.Monad (void, when, unless) import Control.Monad.Catch-#ifndef __HASTE__+import Data.ByteString.Lazy (toStrict)+import Data.Dynamic+import Data.Text as Text (pack, toLower, take)+import Data.Time (FormatTime, formatTime, defaultTimeLocale)+import Data.UUID.Types (toByteString) import Database.SQLite3 import System.Directory (makeAbsolute) #endif +data SQLite+ -- | Open a new connection to an SQLite database. --   The connection is reusable across calls to `runSeldaT`, and must be --   explicitly closed using 'seldaClose' when no longer needed.-sqliteOpen :: (MonadIO m, MonadMask m) => FilePath -> m SeldaConnection-sqliteOpen file = do+sqliteOpen :: (MonadIO m, MonadMask m) => FilePath -> m (SeldaConnection SQLite) #ifdef __HASTE__-  error "sqliteOpen called in JS context"+sqliteOpen _ = error "sqliteOpen called in JS context" #else+sqliteOpen file = do   mask $ \restore -> do     edb <- try $ liftIO $ open (pack file)     case edb of@@ -34,13 +46,24 @@  -- | Perform the given computation over an SQLite database. --   The database is guaranteed to be closed when the computation terminates.-withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT m a -> m a+withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT SQLite m a -> m a #ifdef __HASTE__ withSQLite _ _ = return $ error "withSQLite called in JS context"++sqliteBackend :: a -> SeldaBackend+sqliteBackend _ = error "sqliteBackend called in JS context" #else withSQLite file m = bracket (sqliteOpen file) seldaClose (runSeldaT m) -sqliteBackend :: Database -> SeldaBackend+-- | Create a Selda backend using an already open database handle.+--   This is useful for situations where you want to use some SQLite-specific+--   functionality alongside Selda.+--+--   Note that manipulating the underlying database handle directly voids+--   any and all safety guarantees made by the Selda API.+--   Caching functionality in particular WILL break.+--   Proceed with extreme caution.+sqliteBackend :: Database -> SeldaBackend SQLite sqliteBackend db = SeldaBackend   { runStmt         = \q ps -> snd <$> sqliteQueryRunner db q ps   , runStmtWithPK   = \q ps -> fst <$> sqliteQueryRunner db q ps@@ -57,17 +80,32 @@   , disableForeignKeys = disableFKs db   } -sqliteGetTableInfo :: Database -> Text -> IO [ColumnInfo]+sqliteGetTableInfo :: Database -> Text -> IO TableInfo sqliteGetTableInfo db tbl = do     cols <- (snd . snd) <$> sqliteQueryRunner db tblinfo []-    indexes <- (snd . snd) <$> sqliteQueryRunner db indexes []     fks <- (snd . snd) <$> sqliteQueryRunner db fklist []-    indexes' <- mapM indexInfo indexes-    mapM (describe fks indexes') cols+    createQuery <- (snd . snd) <$> sqliteQueryRunner db autos []+    let cs = case createQuery of+          [[SqlString q]] -> colsFromQuery q+          _               -> []+    ixs <- mapM indexInfo . snd . snd =<< sqliteQueryRunner db indexes []+    colInfos <- mapM (describe fks ixs cs) cols+    return $ TableInfo+      { tableColumnInfos = colInfos+      , tableUniqueGroups =+        [ map mkColName names+        | (names, "u") <- ixs+        ]+      , tablePrimaryKey = concat+        [ map mkColName names+        | (names, "pk") <- ixs+        ]+      }   where     tblinfo = mconcat ["PRAGMA table_info(", tbl, ");"]     indexes = mconcat ["PRAGMA index_list(", tbl, ");"]     fklist = mconcat ["PRAGMA foreign_key_list(", tbl, ");"]+    autos = mconcat ["SELECT sql FROM sqlite_master WHERE name = ", tbl, ";"]     ixinfo name = mconcat ["PRAGMA index_info(", name, ");"]      toTypeRep _ "text"                      = Right TText@@ -82,20 +120,19 @@     toTypeRep _ typ                         = Left typ      indexInfo [_, SqlString ixname, _, SqlString itype, _] = do-      let q = (ixinfo ixname)-      [[_, _, SqlString name]] <- (snd . snd) <$> sqliteQueryRunner db q []-      return (name, itype)+      let q = ixinfo ixname+      info <- (snd . snd) <$> sqliteQueryRunner db q []+      return $ (map (\[_,_,SqlString name] -> name) info, itype)     indexInfo _ = do       error "unreachable" -    describe fks ixs [_, SqlString name, SqlString ty, SqlInt nonnull, _, SqlInt pk] = do+    describe fks ixs cs [_, SqlString name, SqlString ty, SqlInt nonnull, _, SqlInt pk] = do+      let ty' = toLower ty       return $ ColumnInfo         { colName = mkColName name-        , colType = toTypeRep (pk == 1) (toLower ty)-        , colIsPK = pk == 1-        , colIsAutoIncrement = "auto_increment" `isSuffixOf` ty-        , colIsUnique = any (== (name, "u")) ixs || pk == 1-        , colHasIndex = any (== (name, "c")) ixs+        , colType = toTypeRep (pk == 1) ty'+        , colIsAutoPrimary = snd $ fromJust $ lookup name cs+        , colHasIndex = any (== ([name], "c")) ixs         , colIsNullable = nonnull == 0         , colFKs =             [ (mkTableName reftbl, mkColName refkey)@@ -103,7 +140,7 @@             , key == name             ]         }-    describe _ _ result = do+    describe _ _ _ result = do       throwM $ SqlError $ "bad result from PRAGMA table_info: " ++ show result  disableFKs :: Database -> Bool -> IO ()@@ -165,14 +202,15 @@ toSqlData (LInt i)      = SQLInteger $ fromIntegral i toSqlData (LDouble d)   = SQLFloat d toSqlData (LText s)     = SQLText s-toSqlData (LDateTime s) = SQLText s-toSqlData (LDate s)     = SQLText s-toSqlData (LTime s)     = SQLText s+toSqlData (LDateTime t) = SQLText $ pack $ fmtTime sqlDateTimeFormat t+toSqlData (LDate d)     = SQLText $ pack $ fmtTime sqlDateFormat d+toSqlData (LTime t)     = SQLText $ pack $ fmtTime sqlTimeFormat t toSqlData (LBool b)     = SQLInteger $ if b then 1 else 0 toSqlData (LBlob b)     = SQLBlob b toSqlData (LNull)       = SQLNull toSqlData (LJust x)     = toSqlData x-toSqlData (LCustom l)   = toSqlData l+toSqlData (LCustom _ l) = toSqlData l+toSqlData (LUUID x)     = SQLBlob (toStrict $ toByteString x)  fromSqlData :: SQLData -> SqlValue fromSqlData (SQLInteger i) = SqlInt $ fromIntegral i@@ -180,4 +218,7 @@ fromSqlData (SQLText s)    = SqlString s fromSqlData (SQLBlob b)    = SqlBlob b fromSqlData SQLNull        = SqlNull++fmtTime :: FormatTime t => String -> t -> String+fmtTime = formatTime defaultTimeLocale #endif
+ src/Database/Selda/SQLite/Parser.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Incomplete parser for SQL CREATE TABLE statements.+--   Needed to figure out whether any given column is auto-incrementing+--   or not. It's super inefficient, but doesn't really matter since it'll+--   only ever be invoked during validation.+module Database.Selda.SQLite.Parser (colsFromQuery) where+import Control.Applicative+import Control.Monad (void, msum, MonadPlus (..))+import Data.Char (isSpace, isAlpha, isAlphaNum)+import Data.Maybe (isJust, catMaybes)+import Data.Text (Text)+import qualified Data.Text as Text++colsFromQuery :: Text -> [(Text, (Text, Bool))]+colsFromQuery = parse' parseCreateQueryCols++newtype Parser a = P { unP :: (Text -> Maybe (Text, a)) }++instance Functor Parser where+  fmap f (P g) = P (fmap (fmap f) . g)++instance Applicative Parser where+  pure x = P $ \t -> Just (t, x)+  f <*> x = f >>= \f' -> fmap f' x++instance Alternative Parser where+  empty = P $ const Nothing+  P f <|> P g = P $ \s ->+    case f s of+      res@(Just _) -> res+      _            -> g s++instance Monad Parser where+  return = pure+  P m >>= f = P $ \s -> do+    case m s of+      Just (rest, x) -> unP (f x) rest+      _              -> Nothing++instance MonadPlus Parser where+  mzero = empty+  mplus = (<|>)++parse :: Parser a -> Text -> Maybe a+parse (P f) t = snd <$> f t++parse' :: Parser a -> Text -> a+parse' f t = maybe (error $ "no parse: '" ++ show t ++ "'") id $ parse f t++lowerText :: Text -> Parser ()+lowerText prefix = P $ \s ->+  case Text.splitAt (Text.length prefix) s of+    (prefix', rest) | prefix == Text.toLower prefix' -> Just (rest, ())+    _                                                -> Nothing++charP :: (Char -> Bool) -> Parser Char+charP p = P $ \s ->+  case Text.splitAt 1 s of+    (prefix, rest) | Text.any p prefix -> Just (rest, Text.head prefix)+    _                                  -> Nothing++char :: Char -> Parser Char+char c = charP (== c)++space :: Parser ()+space = void $ charP isSpace++spaces :: Parser ()+spaces = void $ some space++sepBy1 :: Parser s -> Parser a -> Parser [a]+sepBy1 sep p = do+  x <- p+  xs <- optional $ sep *> sepBy1 sep p+  case xs of+    Just xs' -> pure (x:xs')+    _        -> pure [x]++commaSeparated :: Parser a -> Parser [a]+commaSeparated = sepBy1 (many space >> char ',' >> many space)++keywords :: [Text]+keywords = ["constraint", "unique", "primary key"]++parseCreateQueryCols :: Parser [(Text, (Text, Bool))]+parseCreateQueryCols = do+  lowerText "create table"+  spaces+  void $ sqliteIdentifier+  void $ many space+  void $ char '('+  cols <- commaSeparated parseCol <* many space+  void $ char ')'+  pure $ catMaybes cols++parseCol :: Parser (Maybe (Text, (Text, Bool)))+parseCol = do+    decl <- constraint <|> column+    pure $ case decl of+      Right col -> Just col+      _         -> Nothing+  where+    column = do+      name <- sqliteIdentifier+      spaces+      ty <- sqliteIdentifier+      void $ optional $ spaces *> lowerText "primary key"+      isAuto <- optional $ spaces *> lowerText "autoincrement"+      void $ many $ charP (\c -> isAlphaNum c || isSpace c)+      void $ optional $ do+        void $ char '('+        void $ commaSeparated sqliteIdentifier+        void $ char ')'+      pure $ Right $ (name, (ty, isJust isAuto))+    constraint = do+      msum (map lowerText keywords)+      void $ many $ msum+        [ void sqliteIdentifier+        , void $ do+            void $ char '('+            void $ commaSeparated sqliteIdentifier+            void $ char ')'+        , spaces+        ]+      pure $ Left ()++sqliteIdentifier :: Parser Text+sqliteIdentifier = Text.pack <$> (quoted <|> unquoted)+  where+    unquoted = do+      x <- charP $ \c -> isAlpha c || c == '_'+      xs <- many $ charP $ \c -> isAlphaNum c || c == '_' || c == '$'+      pure $ (x:xs)+    quoted = char '"' *> many quotedChar <* char '"'+    quotedChar = (char '"' >> char '"') <|> charP (/= '"')