diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# General +\#*# +.*~ +*~ +.#* +*.swp +.DS_Store +.gdb_history +TAGS +# Object files +*.a +*.o +*.so +*.hi +*.p_hi +a.out +# autotool +autom4te.cache +stamp-h1 +# misc +*.sqlite +Main +dist/ +cabal-dev/ +cabal.sandbox.config +.cabal-sandbox*/ +repo/ +.stack-work/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,57 @@ +sudo: false +language: c + +matrix: + include: + - env: GHCVER=7.8.4 STACK_YAML=stack-lts-2.yaml + addons: + apt: + sources: [ hvr-ghc ] + packages: [ ghc-7.8.4 ] + - env: GHCVER=7.10.3 STACK_YAML=stack-lts-5.yaml + addons: + apt: + sources: [ hvr-ghc ] + packages: [ ghc-7.10.3 ] + - env: GHCVER=7.10.3 STACK_YAML=stack-lts-5-hrrhead.yaml + addons: + apt: + sources: [ hvr-ghc ] + packages: [ ghc-7.10.3 ] + - env: GHCVER=7.10.3 STACK_YAML=stack-lts-6.yaml + addons: + apt: + sources: [ hvr-ghc ] + packages: [ ghc-7.10.3 ] + - env: GHCVER=8.0.1 STACK_YAML=stack-lts-7.yaml + addons: + apt: + sources: [ hvr-ghc ] + packages: [ ghc-8.0.1 ] + allow_failures: + - env: GHCVER=7.10.3 STACK_YAML=stack-lts-5-hrrhead.yaml + +before_install: + # Download and unpack the stack executable + - mkdir -p ~/.local/bin + - export PATH=$HOME/.local/bin:/opt:/opt/ghc/$GHCVER/bin:$PATH + - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + # stack searches .cabal file based on STACK_YAML directory. + - cp .travis/stack*.yaml . + +install: + - travis_wait stack --no-terminal --skip-ghc-check setup + - travis_wait stack --no-terminal --skip-ghc-check test --only-snapshot + +before_script: + - mysql -u root -e 'CREATE DATABASE test DEFAULT CHARACTER SET utf8;' + - mysql -u root -e 'GRANT ALL PRIVILEGES ON `test`.* TO travis@localhost;' + +script: + - travis_wait stack --no-terminal --skip-ghc-check test --flag persistent-relational-record:test-examples + + # tests source distribution package + - .travis/check-sdist.sh persistent-relational-record +cache: + directories: + - ~/.stack diff --git a/.travis/check-sdist.sh b/.travis/check-sdist.sh new file mode 100644 --- /dev/null +++ b/.travis/check-sdist.sh @@ -0,0 +1,25 @@ +#!/bin/bash + +BASEDIR="$PWD" +TARGET="$1" +DIST="$(stack path | awk '/^dist-dir/ {print $2}')" + +stack sdist + +if [ ! -f ${DIST%/}/${TARGET}-*.tar.gz ]; then + echo "NG: missing archive" + exit 1 +fi + +cd "$DIST" +srctgz=(${TARGET}*.tar.gz) +srctgz="${srctgz[0]}" +pkgname="${srctgz%.tar.gz}" +tar xvzf "${srctgz}" +cd "$BASEDIR" +NG=$(git ls-tree -r HEAD | while read perm blob hash name; do [ -e "$DIST/$pkgname/$name" ] || echo "$name"; done) +if [ -n "$NG" ]; then + echo "Missing files:" + echo $NG + exit 1 +fi diff --git a/.travis/stack-lts-2.yaml b/.travis/stack-lts-2.yaml new file mode 100644 --- /dev/null +++ b/.travis/stack-lts-2.yaml @@ -0,0 +1,10 @@ +resolver: lts-2.22 +packages: +- '.' +extra-deps: +- names-th-0.2.0.1 +- persistable-record-0.4.0.0 +- relational-query-0.8.2.1 +- sql-words-0.1.4.0 +flags: {} +extra-package-dbs: [] diff --git a/.travis/stack-lts-5-hrrhead.yaml b/.travis/stack-lts-5-hrrhead.yaml new file mode 100644 --- /dev/null +++ b/.travis/stack-lts-5-hrrhead.yaml @@ -0,0 +1,15 @@ +resolver: lts-5.18 +packages: +- location: + git: https://github.com/khibino/haskell-relational-record.git + commit: master + subdirs: + - names-th + - persistable-record + - relational-query + - sql-words +- '.' +extra-deps: +- quickcheck-simple-0.1.0.0 +flags: {} +extra-package-dbs: [] diff --git a/.travis/stack-lts-5.yaml b/.travis/stack-lts-5.yaml new file mode 100644 --- /dev/null +++ b/.travis/stack-lts-5.yaml @@ -0,0 +1,10 @@ +resolver: lts-5.18 +packages: +- '.' +extra-deps: +- names-th-0.2.0.1 +- persistable-record-0.4.0.0 +- relational-query-0.8.2.1 +- sql-words-0.1.4.0 +flags: {} +extra-package-dbs: [] diff --git a/.travis/stack-lts-6.yaml b/.travis/stack-lts-6.yaml new file mode 100644 --- /dev/null +++ b/.travis/stack-lts-6.yaml @@ -0,0 +1,6 @@ +resolver: lts-6.23 +packages: +- '.' +extra-deps: [] +flags: {} +extra-package-dbs: [] diff --git a/.travis/stack-lts-7.yaml b/.travis/stack-lts-7.yaml new file mode 100644 --- /dev/null +++ b/.travis/stack-lts-7.yaml @@ -0,0 +1,11 @@ +resolver: lts-7.5 +packages: +- '.' +extra-deps: +- persistent-mysql-2.6 +- mysql-simple-0.4.0.0 +- mysql-0.1.3 +flags: + persistent-relational-record: + test-examples: True +extra-package-dbs: [] diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2015 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,142 @@ +persistent-relational-record +============================ + +## About ## + +persistent-relational-record build a bridge between +and . +It uses the persistent entities definition instead of obtaining schema from DB at compilation time. + +## Getting Started ## + +If you already define an entities in persistent's manner, then you are almost ready to use this module. +The entities definition in the style of persistent-relational-record are shown below: + +Model.hs: + +~~~~ {.haskell} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} + +import Data.Text (Text) +import Database.Persist.Relational (mkHrrInstances) +import Database.Persist.TH + +share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase| +Image + title Text + deriving Eq Show +Tag + name Text + deriving Eq Show +ImageTag + imageId ImageId + tagId TagId +|] +~~~~ + +The main difference from the persistent version is that `mkSave "db"` and `mkHrrInstances` are added to the 1st argument of the `share` function. +`mkSave "db"` saves the definition of tables to "db" variable for later use. +`mkHrrInstances` generates various instances from the entities definition to cooperate with HRR. + +Next, you should define HRR record types and their instances, +this package provides "defineTableFromPersistent" function to generate those types and auxiliary functnions. +To avoid the conflict of record field names, we recommend making one module per table. + +Here is the content of "Image.hs": + +~~~~ {.haskell} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Image where + +import Data.Text (Text) +import Database.Persist.Relational +import Model hiding (Image) -- Both of HRR and persistent generates `Image` type, so you should hide Image type generated by persistent. +import qualified Model + +defineTableFromPersistent ''Model.Image db +~~~~ + +You should create "Tag.hs" and "ImageTag.hs" in the same manner. + +Now, you can build queries in manner of HRR: + +~~~~ {.haskell} +module Query where + +import Data.Text (Text) +import Database.Relational.Query + +import Model +import qualified Image +import qualified ImageTag +import qualified Tag + +imageIdFromTagNameList + :: [Text] -- ^ list of tag name + -> Relation () ImageId +imageIdFromTagNameList tagNames = aggregateRelation $ do + imgtag <- query $ ImageTag.imageTag + tag <- query $ Tag.tag + on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId' + wheres $ tag ! Tag.name' `in'` values tagNames + g <- groupBy $ imgtag ! ImageTag.imageId' + let c = count $ imgtag ! ImageTag.imageId' + having $ c .=. value (length $ tagNames) + return g + +selectImageByTagNameList + :: [Text] -- ^ list of tag name + -> Relation () Image.Image +selectImageByTagNameList tagNames = relation $ do + img <- query Image.image + imgids <- query $ imageIdFromTagNameList tagNames + on $ img ! Image.id' .=. imgids + return img +~~~~ + +Finally, we can execute a query by runQuery: + +~~~~ {.haskell} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.Base +import Control.Monad.Logger +import Control.Monad.Trans.Resource +import Data.Conduit +import qualified Data.Conduit.List as CL +import Database.Persist.MySQL +import Database.Persist.Relational +import Database.Relational.Query + +import Model +import Query + +sample1 :: SqlPersistT (LoggingT IO) [ImageId] +sample1 = runResourceT $ runQuery (relationalQuery $ imageIdFromTagNameList ["tokyo", "haskell"]) () $$ CL.consume + +sample2 :: SqlPersistT (LoggingT IO) [Entity Image] +sample2 = runResourceT $ runQuery (relationalQuery $ selectImageByTagNameList ["tokyo", "haskell"]) () $$ CL.consume + +main :: IO () +main = runStderrLoggingT $ withMySQLPool defaultConnectInfo 10 $ runSqlPool $ do + mapM_ (liftBase . print) =<< sample1 + mapM_ (liftBase . print) =<< sample2 +~~~~ + +`runQuery` run the HRR `Query` and gives the result as conduit `Source`. +In addition, it converts the result type to persistent's entity if the result type of `Query` is HRR record type. + +For example, the expression `selectImageByTagNameList [...]` has type `Relation () Image.Image`, +but `runQuery (relationalQuery $ selectImageByTagNameList ["tokyo", "haskell"]) ()` has type `Source m (Entity Image)`. + +For a full runnable example, see [examples](https://github.com/himura/persistent-relational-record/tree/master/examples/) directory. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Image.hs b/examples/Image.hs new file mode 100644 --- /dev/null +++ b/examples/Image.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Image where + +import Data.ByteString (ByteString) +import Data.Time (UTCTime) +import Database.Persist.Relational +import Model hiding (Image) +import qualified Model +import Types + +defineTableFromPersistent ''Model.Image db diff --git a/examples/ImageTag.hs b/examples/ImageTag.hs new file mode 100644 --- /dev/null +++ b/examples/ImageTag.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module ImageTag where + +import Database.Persist.Relational +import Model hiding (ImageTag) +import qualified Model + +defineTableFromPersistent ''Model.ImageTag db diff --git a/examples/Model.hs b/examples/Model.hs new file mode 100644 --- /dev/null +++ b/examples/Model.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} + +module Model where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time (UTCTime) +import Database.Persist.Relational (mkHrrInstances) +import Database.Persist.TH +import Types + +share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase| +Image + hash ByteString + type ImageType + created_at UTCTime + changed_at UTCTime + UniqueImageHash hash + deriving Show Eq +Tag + name Text + description Text Maybe + UniqueTagName name + deriving Show Eq +ImageTag + imageId ImageId + tagId TagId + UniqueImageTag imageId tagId + deriving Show Eq +|] diff --git a/examples/Tag.hs b/examples/Tag.hs new file mode 100644 --- /dev/null +++ b/examples/Tag.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Tag where + +import Data.Text (Text) +import Database.Persist.Relational +import qualified Model +import Model hiding (Tag) + +defineTableFromPersistent ''Model.Tag db diff --git a/examples/Types.hs b/examples/Types.hs new file mode 100644 --- /dev/null +++ b/examples/Types.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Types where + +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Relational +import Database.Persist.Sql +import Database.Record.TH (deriveNotNullType, deriveNotNullType) +import Database.Relational.Query.Pure +import Database.Relational.Query.TH (defineScalarDegree, defineScalarDegree) + +data ImageType = JPEG | PNG | BMP | GIF + deriving (Show, Eq, Enum) + +-- * instances for HRR + +deriveNotNullType [t|ImageType|] +defineFromToSqlPersistValue [t|ImageType|] +defineScalarDegree [t|ImageType|] +instance ShowConstantTermsSQL ImageType where + showConstantTermsSQL' = showConstantTermsSQL' . fromEnum + +-- * instances for persistent + +instance PersistFieldSql ImageType where + sqlType _ = SqlInt32 +instance PersistField ImageType where + toPersistValue = PersistInt64 . fromIntegral . fromEnum + fromPersistValue (PersistInt64 v) = Right . toEnum . fromIntegral $ v + fromPersistValue v = Left . T.pack $ "ImageType: Unkown Type, recieved: " ++ show v diff --git a/examples/main.hs b/examples/main.hs new file mode 100644 --- /dev/null +++ b/examples/main.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.Base +import Control.Monad.Logger +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Maybe +import Data.Text (Text) +import Data.Time +import Database.Persist +import Database.Persist.MySQL +import Database.Persist.Relational +import Database.Relational.Query as HRR hiding (fromMaybe) +import System.Environment + +import qualified Image +import qualified ImageTag +import Model +import qualified Tag +import Types + +selectImageByTagNameList + :: Bool -- ^ match any + -> [Text] -- ^ list of tag name + -> Relation () Image.Image +selectImageByTagNameList matchAny tagNames = relation $ do + img <- query Image.image + imgids <- query $ imageIdFromTagNameList matchAny tagNames + on $ img ! Image.id' .=. imgids + return img + +-- ^ query ImageId by tag name list +-- +-- @ +-- SELECT image_id FROM image_tag +-- INNER JOIN tag ON tag.id = image_tag.tag_id +-- WHERE tag.name IN (<>) +-- GROUP BY image_tag.image_id +-- HAVING COUNT(image_tag.image_id) = <> +-- @ +imageIdFromTagNameList + :: Bool -- ^ match any + -> [Text] -- ^ list of tag name + -> Relation () ImageId +imageIdFromTagNameList matchAny tagNames = aggregateRelation $ do + imgtag <- query $ ImageTag.imageTag + tag <- query $ Tag.tag + on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId' + wheres $ tag ! Tag.name' `in'` values tagNames + g <- groupBy $ imgtag ! ImageTag.imageId' + let c = HRR.count $ imgtag ! ImageTag.imageId' + having $ + if matchAny + then c .>. value (0 :: Int) + else c .=. value (fromIntegral . length $ tagNames) + return g + +tagListOfImage :: Relation ImageId Tag.Tag +tagListOfImage = relation' $ placeholder $ \ph -> do + tag <- query Tag.tag + imgtag <- query ImageTag.imageTag + on $ tag ! Tag.id' .=. imgtag ! ImageTag.tagId' + wheres $ imgtag ! ImageTag.imageId' .=. ph + return tag + +addImages :: TagId + -> [Image] + -> SqlPersistT (LoggingT IO) () +addImages tagId images = do + imgIds <- mapM insert images + mapM_ (\imgId -> insert $ ImageTag imgId tagId) imgIds + +printImage :: ByteString -> SqlPersistT (LoggingT IO) () +printImage hkey = + getBy (UniqueImageHash hkey) >>= \case + Just (Entity k val) -> do + liftBase $ print val + runResourceT $ + runQuery (relationalQuery tagListOfImage) k + $$ CL.mapM_ (liftBase . print) + Nothing -> liftBase $ putStrLn "Image not found" + +sample :: SqlPersistT (LoggingT IO) () +sample = do + runMigration migrateAll + now <- liftBase getCurrentTime + + tagShinkuId <- insert $ Tag "shinku" (Just "二階堂真紅") + addImages tagShinkuId + [ Image "4f4221435f9c5c430db2b093c91b8f1f" PNG now now + , Image "11eb1ee2b8f9b471f15d85fb784a8fd6" PNG now now + , Image "7e11b84e04f181179cde72a5d0a5731f" PNG now now + , Image "e10f6af40a80a7f5794ea0bdc66d4ae3" PNG now now + ] + + tagMareId <- insert $ Tag "mare" Nothing + addImages tagMareId + [ Image "fbc717314b90afe6819d4593c583109a" PNG now now + , Image "dc593d1c551f2a1ea85c2dc5521c7fdf" PNG now now + ] + + runResourceT $ + runQuery (relationalQuery $ selectImageByTagNameList False ["shinku"]) () + $$ CL.mapM_ (liftBase . print) + + runResourceT $ + runQuery (relationalQuery $ imageIdFromTagNameList True ["shinku", "mare"]) () + $$ CL.mapM_ (liftBase . print) + + printImage "11eb1ee2b8f9b471f15d85fb784a8fd6" + printImage "fbc717314b90afe6819d4593c583109a" + + mapM_ (liftBase . print) =<< run + +run :: SqlPersistT (LoggingT IO) [Entity Image] +run = runResourceT $ + runQuery (relationalQuery $ selectImageByTagNameList False ["shinku", "mare"]) () $$ CL.consume + +getConnectInfo :: IO ConnectInfo +getConnectInfo = do + host <- fromMaybe "localhost" `fmap` lookupEnv "MYSQL_HOST" + user <- fromMaybe "travis" `fmap` lookupEnv "MYSQL_USER" + pass <- fromMaybe "" `fmap`lookupEnv "MYSQL_PASS" + return defaultConnectInfo + { connectHost = host + , connectUser = user + , connectPassword = pass + , connectDatabase = "test" + } + +main :: IO () +main = do + connInfo <- getConnectInfo + runStderrLoggingT $ withMySQLPool connInfo 10 $ runSqlPool sample diff --git a/persistent-relational-record.cabal b/persistent-relational-record.cabal new file mode 100644 --- /dev/null +++ b/persistent-relational-record.cabal @@ -0,0 +1,109 @@ +name: persistent-relational-record +version: 0.1.0.0 +synopsis: relational-record on persisten backends. +homepage: http://github.com/himura/persistent-relational-record +license: BSD3 +license-file: LICENSE +author: Takahiro HIMURA +maintainer: taka@himura.jp +copyright: 2015 Takahiro Himura +category: Database +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + .gitignore + .travis.yml + .travis/*.sh + .travis/*.yaml + README.md + stack.yaml + +flag test-examples + default: False + manual: False + +library + hs-source-dirs: src + build-depends: base >= 4.7 && < 5 + , conduit >= 1.0 + , containers + , mtl + , persistable-record >= 0.4 + , persistent >= 2.1 + , relational-query >= 0.8.1 + , resourcet >= 1.1 + , template-haskell >= 2.9 + , text >= 0.8 + default-language: Haskell2010 + exposed-modules: Database.Persist.Relational + Database.Persist.Relational.Instances + Database.Persist.Relational.TH + Database.Persist.Relational.ToPersistEntity + ghc-options: -Wall + +test-suite unittest + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: unit.hs + build-depends: base + , HUnit + , persistent-template + , relational-query + , test-framework + , test-framework-hunit + , test-framework-th + , text + , time + , persistent-relational-record + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -fsimpl-tick-factor=200 + default-language: Haskell2010 + other-modules: Fixtures.BlogSample.Model + Fixtures.BlogSample.User + Fixtures.BlogSample.Post + Fixtures.BlogSample.Tag + Fixtures.BlogSample.PostTag + +test-suite hlint + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: hlint.hs + build-depends: + base + , hlint >= 1.7 + default-language: Haskell2010 + +test-suite examples + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: main.hs + + if !flag(test-examples) + buildable: False + else + build-depends: base + , bytestring + , conduit + , monad-logger + , persistable-record + , persistent + , persistent-mysql + , persistent-template + , relational-query + , resourcet + , template-haskell + , text + , time + , transformers-base + , persistent-relational-record + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -O2 -fsimpl-tick-factor=120 + default-language: Haskell2010 + other-modules: Model + Image + ImageTag + Tag + Types + +source-repository head + type: git + location: https://github.com/himura/persistent-relational-record diff --git a/src/Database/Persist/Relational.hs b/src/Database/Persist/Relational.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Relational.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Database.Persist.Relational +-- Copyright : (C) 2016 Takahiro Himura +-- License : BSD3 +-- Maintainer : Takahiro Himura +-- Stability : experimental +-- Portability : unknown +-- +-- This module works as a bridge between +-- and . +-- It uses the persistent entities definition instead of obtaining schema from DB at compilation time. +-- +-- See: +module Database.Persist.Relational + ( runQuery + , rawQuery + , mkHrrInstances + , defineTableFromPersistent + , defineTableFromPersistentWithConfig + , defineFromToSqlPersistValue + , defaultConfig + , ToPersistEntity (..) + ) where + +import Control.Monad.Reader (MonadReader) +import Control.Monad.Trans.Resource (MonadResource) +import Data.Conduit (Source, ($=)) +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Relational.Instances () +import Database.Persist.Relational.TH +import Database.Persist.Relational.ToPersistEntity +import Database.Persist.Sql (SqlBackend) +import qualified Database.Persist.Sql as PersistSql +import Database.Record (ToSql, recordToSql, runFromRecord, runToRecord) +import Database.Relational.Query + +-- | Execute a HRR 'Query' and return the stream of its results. +runQuery :: ( MonadResource m + , MonadReader env m +#if MIN_VERSION_persistent(2, 5, 0) + , HasPersistBackend env + , BaseBackend env ~ SqlBackend +#else + , HasPersistBackend env SqlBackend +#endif + , ToSql PersistValue p + , ToPersistEntity a b + ) + => Query p a -- ^ Query to get record type a requires parameter p + -> p -- ^ Parameter type + -> Source m b +runQuery q vals = rawQuery q vals $= CL.map (runToRecord recordFromSql') + +rawQuery :: ( MonadResource m + , MonadReader env m +#if MIN_VERSION_persistent(2, 5, 0) + , HasPersistBackend env + , BaseBackend env ~ SqlBackend +#else + , HasPersistBackend env SqlBackend +#endif + , ToSql PersistValue p + ) + => Query p a + -> p + -> Source m [PersistValue] +rawQuery q vals = PersistSql.rawQuery queryTxt params + where + queryTxt = T.pack . untypeQuery $ q + params = runFromRecord recordToSql vals diff --git a/src/Database/Persist/Relational/Instances.hs b/src/Database/Persist/Relational/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Relational/Instances.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Relational.Instances + where + +import Database.Persist.Relational.TH +import Database.Record +import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) +import Database.Persist + +instance PersistableType PersistValue where + persistableType = unsafePersistableSqlTypeFromNull PersistNull + +derivePersistableInstancesFromPersistFieldInstances ["SomePersistField"] diff --git a/src/Database/Persist/Relational/TH.hs b/src/Database/Persist/Relational/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Relational/TH.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.Persist.Relational.TH + where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif + +import Data.Int +import Data.List +import qualified Data.Map as M +import Data.Maybe +import qualified Data.Text as T +import Database.Persist +import Database.Persist.Quasi +import Database.Persist.Relational.ToPersistEntity +import qualified Database.Persist.Sql as PersistSql +import Database.Record (PersistableWidth (..)) +import Database.Record.FromSql +import Database.Record.TH (deriveNotNullType, recordType) +import Database.Record.ToSql +import Database.Relational.Query hiding ((!)) +import Database.Relational.Query.TH (defineTable, defineScalarDegree) +import Language.Haskell.TH + +ftToType :: FieldType -> TypeQ +ftToType (FTTypeCon Nothing t) = conT $ mkName $ T.unpack t +-- This type is generated from the Quasi-Quoter. +-- Adding this special case avoids users needing to import Data.Int +ftToType (FTTypeCon (Just "Data.Int") "Int64") = conT ''Int64 +ftToType (FTTypeCon (Just m) t) = conT $ mkName $ T.unpack $ T.concat [m, ".", t] +ftToType (FTApp x y) = ftToType x `appT` ftToType y +ftToType (FTList x) = listT `appT` ftToType x + +makeColumns :: EntityDef + -> [(String, TypeQ)] +makeColumns t = + mkCol (entityId t) : map mkCol (entityFields t) + where + mkCol fd = (toS $ fieldDB fd, mkFieldType fd) + toS = T.unpack . unDBName + +-- | Generate all templates about table from persistent table definition. +defineTableFromPersistentWithConfig + :: Config -- ^ Configration for haskell relational record + -> String -- ^ Database schema name + -> Name -- ^ Name of the persistent record type corresponds to the table + -> [EntityDef] -- ^ @EntityDef@ which is generated by persistent + -> Q [Dec] +defineTableFromPersistentWithConfig config schema persistentRecordName entities = + case filter ((== nameBase persistentRecordName) . T.unpack . unHaskellName . entityHaskell) entities of + (t:_) -> do + let columns = makeColumns t + tableName = T.unpack . unDBName . entityDB $ t + tblD <- defineTable + config + schema + tableName + columns + (map (mkName . T.unpack) . entityDerives $ t) + [0] + (Just 0) + entI <- makeToPersistEntityInstance config schema tableName persistentRecordName columns + return $ tblD ++ entI + _ -> error $ "makeColumns: Table related to " ++ show persistentRecordName ++ " not found" + +-- | Generate all templates about table from persistent table definition using default naming rule. +defineTableFromPersistent + :: Name -- ^ Name of the persistent record type corresponds to the table + -> [EntityDef] -- ^ @EntityDef@ which is generated by persistent + -> Q [Dec] +defineTableFromPersistent = + defineTableFromPersistentWithConfig + defaultConfig { schemaNameMode = SchemaNotQualified } + (error "[bug] Database.Persist.Relational.TH.defineTableFromPersistent: schema name must not be used") + +makeToPersistEntityInstance :: Config -> String -> String -> Name -> [(String, TypeQ)] -> Q [Dec] +makeToPersistEntityInstance config schema tableName persistentRecordName columns = do + (typName, dataConName) <- recType <$> reify persistentRecordName + deriveToPersistEntityForRecord hrrRecordType (conT typName, conE dataConName) columns + where +#if MIN_VERSION_template_haskell(2, 11, 0) + recType (TyConI (DataD _ tName [] _ [RecC dcName _] _)) = (tName, dcName) +#else + recType (TyConI (DataD _ tName [] [RecC dcName _] _)) = (tName, dcName) +#endif + recType info = error $ "makeToPersistEntityInstance: unexpected record info " ++ show info + + hrrRecordType = recordType (recordConfig . nameConfig $ config) schema tableName + +-- | Generate instances for haskell-relational-record. +mkHrrInstances :: [EntityDef] -> Q [Dec] +mkHrrInstances entities = + concat `fmap` mapM mkHrrInstancesEachEntityDef entities + +mkHrrInstancesEachEntityDef :: EntityDef -> Q [Dec] +mkHrrInstancesEachEntityDef = mkPersistablePrimaryKey . entityId + +mkPersistablePrimaryKey :: FieldDef -> Q [Dec] +mkPersistablePrimaryKey fd = do + notNullD <- deriveNotNullType typ + persistableD <- defineFromToSqlPersistValue typ + scalarDegD <- defineScalarDegree typ + showCTermSQLD <- mkShowConstantTermsSQL typ + toPersistEntityD <- deriveTrivialToPersistEntity typ + return $ notNullD ++ persistableD ++ scalarDegD ++ showCTermSQLD ++ toPersistEntityD + where + typ = mkFieldType fd + +mkShowConstantTermsSQL :: TypeQ -> Q [Dec] +mkShowConstantTermsSQL typ = + [d|instance ShowConstantTermsSQL $typ where + showConstantTermsSQL' = showConstantTermsSQL' . PersistSql.fromSqlKey|] + +mkFieldType :: FieldDef -> TypeQ +mkFieldType fd = + case nullable . fieldAttrs $ fd of + Nullable ByMaybeAttr -> conT ''Maybe `appT` typ + _ -> typ + where + typ = ftToType . fieldType $ fd + +-- | Generate 'FromSql' 'PersistValue' and 'ToSql' 'PersistValue' instances for 'PersistField' types. +defineFromToSqlPersistValue :: TypeQ -> Q [Dec] +defineFromToSqlPersistValue typ = do + fromSqlI <- + [d| instance FromSql PersistValue $typ where + recordFromSql = valueRecordFromSql unsafePersistValueFromSql |] + toSqlI <- + [d| instance ToSql PersistValue $typ where + recordToSql = valueRecordToSql toPersistValue |] + return $ fromSqlI ++ toSqlI + +deriveTrivialToPersistEntity :: TypeQ -> Q [Dec] +deriveTrivialToPersistEntity typ = + [d| instance ToPersistEntity $typ $typ where + recordFromSql' = recordFromSql |] + +deriveToPersistEntityForRecord :: TypeQ -> (TypeQ, ExpQ) -> [(String, TypeQ)] -> Q [Dec] +deriveToPersistEntityForRecord hrrTyp (pTyp, pCon) ((_, pKeyTyp):columns) = + [d| instance ToPersistEntity $hrrTyp (Entity $pTyp) where + recordFromSql' = Entity <$> (recordFromSql :: RecordFromSql PersistValue $pKeyTyp) <*> $rfsql |] + where + fields = map (\(_, typ) -> [| recordFromSql :: RecordFromSql PersistValue $typ |]) columns + rfsql = foldl' (\s a -> [| $s <*> $a |]) [| pure $pCon |] fields +deriveToPersistEntityForRecord _ _ [] = fail "deriveToPersistEntityForRecord: missing columns" + +unsafePersistValueFromSql :: PersistField a => PersistValue -> a +unsafePersistValueFromSql v = + case fromPersistValue v of + Left err -> error $ T.unpack err + Right a -> a + +persistValueTypesFromPersistFieldInstances + :: [String] -- ^ blacklist types + -> Q (M.Map Name TypeQ) +persistValueTypesFromPersistFieldInstances blacklist = do + pf <- reify ''PersistField + pfT <- [t|PersistField|] + case pf of + ClassI _ instances -> return . M.fromList $ mapMaybe (go pfT) instances + unknown -> fail $ "persistValueTypesFromPersistFieldInstances: unknown declaration: " ++ show unknown + where +#if MIN_VERSION_template_haskell(2, 11, 0) + go pfT (InstanceD _ [] (AppT insT t@(ConT n)) []) +#else + go pfT (InstanceD [] (AppT insT t@(ConT n)) []) +#endif + | insT == pfT + && nameBase n `notElem` blacklist = Just (n, return t) + go _ _ = Nothing + +persistableWidthTypes :: Q (M.Map Name TypeQ) +persistableWidthTypes = + reify ''PersistableWidth >>= goI + where + unknownDecl decl = fail $ "persistableWidthTypes: Unknown declaration: " ++ show decl + goI (ClassI _ instances) = return . M.fromList . mapMaybe goD $ instances + goI unknown = unknownDecl unknown +#if MIN_VERSION_template_haskell(2, 11, 0) + goD (InstanceD _ _cxt (AppT _insT a@(ConT n)) _defs) = Just (n, return a) +#else + goD (InstanceD _cxt (AppT _insT a@(ConT n)) _defs) = Just (n, return a) +#endif + goD _ = Nothing + +derivePersistableInstancesFromPersistFieldInstances + :: [String] -- ^ blacklist types + -> Q [Dec] +derivePersistableInstancesFromPersistFieldInstances blacklist = do + types <- persistValueTypesFromPersistFieldInstances blacklist + pwts <- persistableWidthTypes + ftsql <- concatMapTypes defineFromToSqlPersistValue types + toER <- concatMapTypes deriveTrivialToPersistEntity types + ws <- concatMapTypes deriveNotNullType $ types `M.difference` pwts + return $ ftsql ++ toER ++ ws + where + concatMapTypes :: (Q Type -> Q [Dec]) -> M.Map Name TypeQ -> Q [Dec] + concatMapTypes f = fmap concat . mapM f . M.elems diff --git a/src/Database/Persist/Relational/ToPersistEntity.hs b/src/Database/Persist/Relational/ToPersistEntity.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Relational/ToPersistEntity.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Persist.Relational.ToPersistEntity + where + +import Database.Record.FromSql (RecordFromSql, recordFromSql, (<&>)) +import Database.Persist (PersistValue) + +class ToPersistEntity a b | a -> b, b -> a where + recordFromSql' :: RecordFromSql PersistValue b + +instance ToPersistEntity () () where + recordFromSql' = recordFromSql + +instance (ToPersistEntity a c, ToPersistEntity b d) => ToPersistEntity (a, b) (c, d) where + recordFromSql' = recordFromSql' <&> recordFromSql' diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,11 @@ +resolver: lts-7.5 +packages: +- '.' +extra-deps: +- persistent-mysql-2.6 +- mysql-simple-0.4.0.0 +- mysql-0.1.3 +flags: + persistent-relational-record: + test-examples: True +extra-package-dbs: [] diff --git a/tests/Fixtures/BlogSample/Model.hs b/tests/Fixtures/BlogSample/Model.hs new file mode 100644 --- /dev/null +++ b/tests/Fixtures/BlogSample/Model.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Fixtures.BlogSample.Model where + +import Data.Text +import Data.Time +import Database.Persist.TH +import Database.Persist.Relational + +share [mkPersist sqlSettings, mkMigrate "migrateAll", mkSave "db", mkHrrInstances] [persistLowerCase| +User + name Text + age Int + UniqueUserName name + deriving Show Eq +Post + title Text + userId UserId + created UTCTime + body Text + deriving Show Eq +Tag + name Text + UniqueTagName name + deriving Show Eq +PostTag + postId PostId + tagId TagId + UniquePostTag postId tagId + deriving Show Eq +|] diff --git a/tests/Fixtures/BlogSample/Post.hs b/tests/Fixtures/BlogSample/Post.hs new file mode 100644 --- /dev/null +++ b/tests/Fixtures/BlogSample/Post.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Fixtures.BlogSample.Post where + +import Data.Text (Text) +import Data.Time +import Database.Persist.Relational +import Fixtures.BlogSample.Model hiding (Post) +import qualified Fixtures.BlogSample.Model as Model + +defineTableFromPersistent ''Model.Post db + diff --git a/tests/Fixtures/BlogSample/PostTag.hs b/tests/Fixtures/BlogSample/PostTag.hs new file mode 100644 --- /dev/null +++ b/tests/Fixtures/BlogSample/PostTag.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Fixtures.BlogSample.PostTag where + +import Database.Persist.Relational +import Fixtures.BlogSample.Model hiding (PostTag) +import qualified Fixtures.BlogSample.Model as Model + +defineTableFromPersistent ''Model.PostTag db + diff --git a/tests/Fixtures/BlogSample/Tag.hs b/tests/Fixtures/BlogSample/Tag.hs new file mode 100644 --- /dev/null +++ b/tests/Fixtures/BlogSample/Tag.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Fixtures.BlogSample.Tag where + +import Data.Text (Text) +import Database.Persist.Relational +import Fixtures.BlogSample.Model hiding (Tag) +import qualified Fixtures.BlogSample.Model as Model + +defineTableFromPersistent ''Model.Tag db + diff --git a/tests/Fixtures/BlogSample/User.hs b/tests/Fixtures/BlogSample/User.hs new file mode 100644 --- /dev/null +++ b/tests/Fixtures/BlogSample/User.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Fixtures.BlogSample.User where + +import Data.Text (Text) +import Database.Persist.Relational +import Fixtures.BlogSample.Model hiding (User) +import qualified Fixtures.BlogSample.Model as Model + +defineTableFromPersistent ''Model.User db + diff --git a/tests/hlint.hs b/tests/hlint.hs new file mode 100644 --- /dev/null +++ b/tests/hlint.hs @@ -0,0 +1,20 @@ +module Main where + +import Control.Monad +import Data.Maybe +import Language.Haskell.HLint +import System.Environment +import System.Exit + +main :: IO () +main = do + args <- getArgs + cabalMacros <- getCabalMacrosPath + hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi", "--cpp-file=" ++ cabalMacros] ++ args + unless (null hints) exitFailure + +getCabalMacrosPath :: IO FilePath +getCabalMacrosPath = do + env <- getEnvironment + let dist = fromMaybe "dist" $ lookup "HASKELL_DIST_DIR" env + return $ dist ++ "/build/autogen/cabal_macros.h" diff --git a/tests/unit.hs b/tests/unit.hs new file mode 100644 --- /dev/null +++ b/tests/unit.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Database.Relational.Query as HRR +import Fixtures.BlogSample.Model +import qualified Fixtures.BlogSample.Post as Post +import qualified Fixtures.BlogSample.PostTag as PostTag +import qualified Fixtures.BlogSample.Tag as Tag +import qualified Fixtures.BlogSample.User as User +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.TH +import Test.HUnit + +case_simple_equal_string_query :: Assertion +case_simple_equal_string_query = + show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.name = 'testuser')" + where + subject = relation $ do + user <- query User.user + wheres $ user ! User.name' .=. value "testuser" + return user + +case_simple_equal_id_query :: Assertion +case_simple_equal_id_query = + show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.id = 1)" + where + subject = relation $ do + user <- query User.user + wheres $ user ! User.id' .=. value (UserKey 1) + return user + +case_simple_equal_placeholder :: Assertion +case_simple_equal_placeholder = + show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.id = ?)" + where + subject = relation' . placeholder $ \ph -> do + user <- query User.user + wheres $ user ! User.id' .=. ph + return user + +case_simple_comparing_int_query :: Assertion +case_simple_comparing_int_query = + show subject @?= "SELECT ALL T0.id AS f0, T0.name AS f1, T0.age AS f2 FROM user T0 WHERE (T0.age >= 18)" + where + subject = relation $ do + user <- query User.user + wheres $ user ! User.age' .>=. value 18 + return user + +case_inner_join_query :: Assertion +case_inner_join_query = + show subject @?= "SELECT ALL T0.id AS f0, T0.title AS f1, T0.user_id AS f2, T0.created AS f3, T0.body AS f4 \ + \FROM post T0 INNER JOIN user T1 ON (T1.id = T0.user_id) WHERE (T1.age > 18)" + where + subject = relation $ do + post <- query Post.post + user <- query User.user + on $ user ! User.id' .=. post ! Post.userId' + wheres $ user ! User.age' .>. value 18 + return post + +case_inner_join_with_subquery :: Assertion +case_inner_join_with_subquery = + show subject @?= "SELECT ALL T0.id AS f0, T0.title AS f1, T0.user_id AS f2, T0.created AS f3, T0.body AS f4 \ + \FROM post T0 \ + \INNER JOIN (SELECT ALL T2.post_id AS f0 FROM tag T1 \ + \INNER JOIN post_tag T2 ON (T1.id = T2.tag_id) \ + \WHERE (T1.name IN ('haskell', 'hrr')) \ + \GROUP BY T2.post_id HAVING (COUNT(T2.post_id) = 2)) T3 \ + \ON (T0.id = T3.f0)" + where + subject = relation $ do + post <- query Post.post + postids <- query $ postIdsFromTagNameList ["haskell", "hrr"] + on $ post ! Post.id' .=. postids + return post + + postIdsFromTagNameList taglist = aggregateRelation $ do + tag <- query Tag.tag + posttag <- query PostTag.postTag + on $ tag ! Tag.id' .=. posttag ! PostTag.tagId' + wheres $ tag ! Tag.name' `in'` values taglist + g <- groupBy $ posttag ! PostTag.postId' + let c = HRR.count $ posttag ! PostTag.postId' + having $ c .=. value (length taglist) + return g + +main :: IO () +main = defaultMain [$testGroupGenerator]