hasqlator-mysql 0.2.1 → 0.2.2

raw patch · 4 files changed

+188/−118 lines, 4 filesdep +non-emptydep ~mysql-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: non-empty

Dependency ranges changed: mysql-haskell

API changes (from Hackage documentation)

Files

• hasqlator-mysql.cabal +3/−2
• src/Database/MySQL/Hasqlator.hs +121/−46
• src/Database/MySQL/Hasqlator/Typed.hs +6/−66
• src/Database/MySQL/Hasqlator/Typed/Schema.hs +58/−4

@@ -1,5 +1,5 @@ Name:		hasqlator-mysql-Version: 	0.2.1+Version: 	0.2.2 Synopsis:	composable SQL generation Category: 	Database Copyright: 	Kristof Bastiaensen (2020)@@ -36,7 +36,7 @@                  io-streams >= 1.5.2.1,                  megaparsec,                  mtl >= 2.1.3,-                 mysql-haskell,+                 mysql-haskell >= 1.1.7,                  prettyprinter,                  scientific,                  text,@@ -44,6 +44,7 @@                  template-haskell,                  aeson,                  pretty-simple,+                 non-empty,                  optics-core >= 0.3 && < 0.5   hs-source-dirs:     src                 

@@ -8,6 +8,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-}+{-# LANGUAGE AllowAmbiguousTypes #-}  {-| Module      : Database.Hasqelator@@ -87,10 +88,12 @@  Similarly, you can use a lens to match the fields, using `lensInto` -> insertValues "authors" (_1 `lensInto` "name" <> _2 `lensInto` "birth_year")->   [("J.K. Rowling", 1965),->    ("Leo Tolstoy", 1828),->    ("Harper Lee", 1926)]+@+insertValues "authors" (_1 `lensInto` "name" <> _2 `lensInto` "birth_year")+  [("J.K. Rowling", 1965),+   ("Leo Tolstoy", 1828),+   ("Harper Lee", 1926)]+@  == Data types @@ -100,47 +103,50 @@ use skipInsert instead of the table name to skip fields you don't care about. -> data Borrower = Borrower->   { name :: Text->   , date_of_birth :: Day->   }->-> insertValues "borrowers" (insertData ("name", "date_of_birth"))->    [Borrower "John Doe" (fromJulian 1985 6 15),->     Borrower "Jane Smith" (fromJulian 1990 11 23),->     Borrower "Emily Johnson" (fromJulian 2000 8 30),->     Borrower "Michael Brown" (fromJulian 1982 2 10),->     Borrower "Sarah Davis" (fromJulian 1995 03 12)]+@+data Borrower = Borrower+  { name :: Text+  , date_of_birth :: Day+  } +insertValues "borrowers" (insertData ("name", "date_of_birth"))+   [Borrower "John Doe" (fromJulian 1985 6 15),+    Borrower "Jane Smith" (fromJulian 1990 11 23),+    Borrower "Emily Johnson" (fromJulian 2000 8 30),+    Borrower "Michael Brown" (fromJulian 1982 2 10),+    Borrower "Sarah Davis" (fromJulian 1995 03 12)]+@+ == Expressions  Insert values can have arbitrary SQL queries, by using the `exprInto` function.  Here I create a subquery, from the query which fetches author_id from an author name. -> data Book = Book->   { title :: String->   , author :: String->   , publishedYear :: Int->   , ageRating :: Int->   }->-> getBookAuthorId : Book -> Query Int-> getBookAuthorId Book{author=a} =->    select (sel "id") $->    from "authors" <>->    where_ ["name" =. arg a]-> -> insertValues (title `into` "title" <>->               (subQuery . getBookAuthorId `exprInto` "author_id") <>->               publishedYear `into` "published_year" <>->               ageRating `into` "age_rating")->   [ Book "1984" "George Orwell" 1903 16->   , Book "Brave New World" "Aldous Huxley" 1932 14,->   , Book "Harry Potter and the Philosopher\'s Stone" "J.K. Rowling" 1997 7->   , Book "War and Peace" "Leo Tolstoy" 1869 18->   ]+@+data Book = Book+  { title :: String+  , author :: String+  , publishedYear :: Int+  , ageRating :: Int+  } +getBookAuthorId : Book -> Query Int+getBookAuthorId Book{author=a} =+   select (sel "id") $+   from "authors" <>+   where_ ["name" =. arg a]++>>> insertValues (title `into` "title" <>+              (subQuery . getBookAuthorId `exprInto` "author_id") <>+              publishedYear `into` "published_year" <>+              ageRating `into` "age_rating")+  [ Book "1984" "George Orwell" 1903 16+  , Book "Brave New World" "Aldous Huxley" 1932 14,+  , Book "Harry Potter and the Philosopher\'s Stone" "J.K. Rowling" 1997 7+  , Book "War and Peace" "Leo Tolstoy" 1869 18+  ]+@ = Querying  Queries are done using the `select` function.  It takes a `Selector`,@@ -162,7 +168,7 @@ haskell datastructure.  The query body can be composed using Monoid `mappend` (`<>`).  For-example, here is a more complicated expression to get all books loaned+example, here is as more complicated expression to get all books loaned by a specific borrower:  @@@ -236,13 +242,13 @@     localTimeSel, timeOfDaySel, diffTimeSel, daySel, byteStringSel,     textSel,     -- ** other selectors-    rawValues, rawValues_,+    rawValues, rawValues_, rawValue,      -- * Expressions     subQuery,     arg, fun, op, isNull, isNotNull, (>.), (<.), (>=.), (<=.), (+.), (-.), (*.),     (/.), (=.), (++.), (/=.), (&&.), (||.), abs_, negate_, signum_, sum_,-    rawSql, substr, in_, false_, true_, notIn_, values,+    rawSql, substr, in_, false_, true_, notIn_, values, Castable(..),      -- * Insertion     Insertor, insertValues, insertUpdateValues, insertSelect, insertData,@@ -295,8 +301,6 @@ import qualified System.IO.Streams as Streams import Control.Exception (throw, Exception) import qualified Data.Aeson as Aeson-import qualified Data.Aeson.Text as Aeson-import qualified Data.Text.Lazy as LazyText import Data.Maybe (mapMaybe)  class FromSql a where@@ -743,9 +747,6 @@   InsertGeneric (M1 m1 m2 a ()) (M1 m3 m4 b ()) where   insertDataGeneric = contramap unM1 . insertDataGeneric . unM1 -instance ToSql b => InsertGeneric (K1 r Text ()) (K1 r b ()) where-  insertDataGeneric = contramap unK1 . insertOne . unK1- instance InsertGeneric (K1 r (Insertor a) ()) (K1 r a ()) where   insertDataGeneric = contramap unK1 . unK1 @@ -958,12 +959,21 @@ -- | Read the columns directly as a `MySQLValue` type without conversion. rawValues :: [QueryBuilder] -> Selector [MySQLValue] rawValues cols = Selector (DList.fromList cols) $-              state $ splitAt (length cols)+                 state $ splitAt (length cols)  -- | Ignore the content of the given columns rawValues_ :: [QueryBuilder] -> Selector () rawValues_ cols = () <$ rawValues cols +-- | Read a column as a `MySQLValue` type without conversion.+rawValue :: QueryBuilder -> Selector MySQLValue+rawValue col = Selector (DList.singleton col) $ do+  vals <- get+  case vals of+    [] -> throwError ResultSetCountError+    (v:rest) -> do put rest+                   pure v+ forUpdate :: [QueryBuilder] -> WaitLock -> QueryClauses forUpdate qb wl = QueryClauses $ Endo $ \qc ->   qc { _lockMode = Just $ ForUpdate qb wl }@@ -1026,6 +1036,71 @@     removeIt = map (`elem` toRemove) fields     removeMaybe (True, _) = Nothing     removeMaybe (False, x) = Just x++class Castable a where+  -- | Safe cast.  This uses the SQL CAST function to convert safely+  -- from one type to another.  Intended to be used with type applications+  -- (e.g. cast @Int expr)+  cast :: QueryBuilder -> QueryBuilder++castTo :: QueryBuilder -> QueryBuilder -> QueryBuilder+castTo tp x = fun "cast" [x `as` tp]++instance Castable StrictBS.ByteString where+  cast = castTo "BINARY"++instance Castable Text where+  cast = castTo "CHAR UNICODE"++instance Castable Day where+  cast = castTo "DATE"++instance Castable LocalTime where+  cast = castTo "DATETIME"++instance Castable Scientific where+  cast = castTo "DECIMAL"++instance Castable Double where+  cast = castTo "FLOAT[53]"++instance Castable Int where+  cast = castTo "SIGNED"++instance Castable Int8 where+  cast = castTo "SIGNED"++instance Castable Int16 where+  cast = castTo "SIGNED"++instance Castable Int32 where+  cast = castTo "SIGNED"++instance Castable Int64 where+  cast = castTo "SIGNED"++instance Castable TimeOfDay where+  cast = castTo "TIME"++instance Castable DiffTime where+  cast = castTo "TIME"++instance Castable Word where+  cast = castTo "UNSIGNED"++instance Castable Word8 where+  cast = castTo "UNSIGNED"++instance Castable Word16 where+  cast = castTo "UNSIGNED"++instance Castable Word32 where+  cast = castTo "UNSIGNED"++instance Castable Word64 where+  cast = castTo "UNSIGNED"++      instance FromSql Bool where   fromSql (MySQLInt8U x) = pure $ x /= 0

@@ -355,72 +355,12 @@            -> Expression 'NotNull Bool unlessNull e f = f (coerce e) -class Castable a where-  -- | Safe cast.  This uses the SQL CAST function to convert safely-  -- from one type to another.-  cast :: Expression nullable b-       -> Expression nullable a--castTo :: H.QueryBuilder-       -> Expression nullable b-       -> Expression nullable a-castTo tp (Expression e) = Expression $ do-  x <- e-  pure $ H.fun "cast" [x `H.as` tp]--instance Castable StrictBS.ByteString where-  cast = castTo "BINARY"--instance Castable Text where-  cast = castTo "CHAR UNICODE"--instance Castable Day where-  cast = castTo "DATE"--instance Castable LocalTime where-  cast = castTo "DATETIME"--instance Castable Scientific where-  cast = castTo "DECIMAL"--instance Castable Double where-  cast = castTo "FLOAT[53]"--instance Castable Int where-  cast = castTo "SIGNED"--instance Castable Int8 where-  cast = castTo "SIGNED"--instance Castable Int16 where-  cast = castTo "SIGNED"--instance Castable Int32 where-  cast = castTo "SIGNED"--instance Castable Int64 where-  cast = castTo "SIGNED"--instance Castable TimeOfDay where-  cast = castTo "TIME"--instance Castable DiffTime where-  cast = castTo "TIME"--instance Castable Word where-  cast = castTo "UNSIGNED"--instance Castable Word8 where-  cast = castTo "UNSIGNED"--instance Castable Word16 where-  cast = castTo "UNSIGNED"--instance Castable Word32 where-  cast = castTo "UNSIGNED"--instance Castable Word64 where-  cast = castTo "UNSIGNED"+-- | Safe cast.  This uses the SQL CAST function to convert safely+-- from one type to another.+cast :: forall a b nullable . H.Castable a+     => Expression nullable b+     -> Expression nullable a+cast (Expression e) = Expression $ H.cast @a <$> e  -- | Cast the return type of an expression to any other type, without -- changing the query. Since this library adds static typing on top of

@@ -5,6 +5,8 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}+{- HLINT ignore STAN-0206 -} module Database.MySQL.Hasqlator.Typed.Schema   (TableInfo(..), ColumnInfo(..), fetchTableInfo, Sign(..), ColumnType(..),    pprTableInfo, Properties(..), defaultProperties, makeFields,@@ -31,6 +33,7 @@ import Data.Char import GHC.TypeLits(Symbol) import Text.Pretty.Simple+import Data.List.NonEmpty (groupWith, NonEmpty(..))  data Sign = Signed | Unsigned   deriving Show@@ -75,8 +78,18 @@   { tableName :: Text   , tableSchema :: Text   , tableColumns :: [ColumnInfo]+  , uniqueKeys :: [[Text]]   } deriving (Show) +data UniqueKeys = UniqueKeys+  { uniqueKeysTableSchema :: Text+  , uniqueKeysTableName :: Text+  , constraintName :: Text+  , uniqueKeysColumnName :: Text+  } deriving (Show)+++ argsP :: Parsec () Text a -> Parsec () Text [a] argsP p = between (single '(') (single ')') $ sepBy p (single ',') @@ -149,7 +162,34 @@           tableSchema_ <- textSel "TABLE_SCHEMA"           pure $ TableInfo{ tableName = tableName_                           , tableSchema = tableSchema_-                          , tableColumns = []}+                          , tableColumns = []+                          , uniqueKeys = []}++uniqueKeysQuery :: [Text] -> Query UniqueKeys+uniqueKeysQuery schemas =+  select keysSelector $+  from ("information_schema.TABLE_CONSTRAINTS" `as` "tc")+  <> leftJoin ["information_schema.KEY_COLUMN_USAGE" `as` "kcu"]+  [ "tc.CONSTRAINT_NAME" =. "kcu.CONSTRAINT_NAME"+  , "tc.TABLE_SCHEMA" =. "kcu.TABLE_SCHEMA"+  , "tc.TABLE_NAME" =. "kcu.TABLE_NAME"]+  <> where_ [ "tc.CONSTRAINT_TYPE" =. arg ("UNIQUE" :: Text)+            , "tc.TABLE_SCHEMA" `in_` map arg schemas]+  <> orderBy [Asc "tc.TABLE_SCHEMA",+              Asc "tc.TABLE_NAME",+              Asc "tc.CONSTRAINT_NAME",+              Asc "kcu.ORDINAL_POSITION"]+  where keysSelector = do+          tableSchema <- textSel "tc.TABLE_SCHEMA"+          tableName <- textSel "tc.TABLE_NAME"+          constraintName <- textSel "tc.CONSTRAINT_NAME"+          columnName <- textSel "kcu.COLUMN_NAME"+          pure $ UniqueKeys+            { uniqueKeysTableSchema = tableSchema+            , uniqueKeysTableName = tableName+            , constraintName = constraintName+            , uniqueKeysColumnName = columnName+            }    columnsQuery :: [Text] -> Query ColumnInfo columnsQuery schemas =@@ -196,14 +236,27 @@ fetchTableInfo conn schemas = do   tables <- executeQuery conn $ tableQuery schemas   columns <- executeQuery conn $ columnsQuery schemas+  uniqueKeys <- executeQuery conn $ uniqueKeysQuery schemas   let columnMap = Map.fromListWith (++) $                   map (\ci -> ( (columnTableSchema ci, columnTableName ci)                               , [ci]))                   columns+      keysMap = Map.fromListWith (++) $+                  map (\(uk1:|uks) ->+                               ( (uniqueKeysTableSchema uk1,+                                  uniqueKeysTableName uk1)+                               , [map uniqueKeysColumnName (uk1:uks)])) $+                  groupWith (\uk ->+                                (uniqueKeysTableSchema uk,+                                 uniqueKeysTableName uk,+                                 constraintName uk))+                  uniqueKeys   pure $     map (\tbl@TableInfo{tableName, tableSchema} ->            tbl {tableColumns = Map.findWithDefault [] (tableSchema, tableName)-                               columnMap} )+                               columnMap,+                uniqueKeys = Map.findWithDefault [] (tableSchema, tableName)+                               keysMap} )     tables  pprTableInfo :: LazyText.Text -> [TableInfo] -> LazyText.Text@@ -213,7 +266,7 @@  columnTHType :: Bool -> ColumnInfo -> Q Type columnTHType ignoreMaybe ColumnInfo{ columnType, columnNullable}-  | columnNullable && not ignoreMaybe = [t| Maybe $(tp) |]+  | columnNullable && not ignoreMaybe = [t| Maybe $tp |]   | otherwise = tp   where tp = case columnType of           TinyIntColumn _  -> [t| Int |]@@ -425,7 +478,8 @@                  |]            , valD (varP insertorName)              (normalB $ foldr1 (\x y -> [| $(x) <> $(y) |]) $-              map insertorField $ filter (not . autoIncrement) $ tableColumns ti)+              map insertorField $ filter (not . autoIncrement) $+              tableColumns ti)              []            ]   where