packages feed

persistent-relational-record (empty) → 0.1.0.0

raw patch · 30 files changed

+1224/−0 lines, 30 filesdep +HUnitdep +basedep +bytestringsetup-changed

Dependencies added: HUnit, base, bytestring, conduit, containers, hlint, monad-logger, mtl, persistable-record, persistent, persistent-mysql, persistent-relational-record, persistent-template, relational-query, resourcet, template-haskell, test-framework, test-framework-hunit, test-framework-th, text, time, transformers-base

Files

+ .gitignore view
@@ -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/
+ .travis.yml view
@@ -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
+ .travis/check-sdist.sh view
@@ -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
+ .travis/stack-lts-2.yaml view
@@ -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: []
+ .travis/stack-lts-5-hrrhead.yaml view
@@ -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: []
+ .travis/stack-lts-5.yaml view
@@ -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: []
+ .travis/stack-lts-6.yaml view
@@ -0,0 +1,6 @@+resolver: lts-6.23+packages:+- '.'+extra-deps: []+flags: {}+extra-package-dbs: []
+ .travis/stack-lts-7.yaml view
@@ -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: []
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,142 @@+persistent-relational-record+============================++## About ##++persistent-relational-record build a bridge between <https://hackage.haskell.org/package/relational-query Haskell Relational Record>+and <http://hackage.haskell.org/package/persistent Persistent>.+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Image.hs view
@@ -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
+ examples/ImageTag.hs view
@@ -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
+ examples/Model.hs view
@@ -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+|]
+ examples/Tag.hs view
@@ -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
+ examples/Types.hs view
@@ -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
+ examples/main.hs view
@@ -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 (<<tagNames>>)+-- GROUP BY image_tag.image_id+-- HAVING COUNT(image_tag.image_id) = <<length tagNames>>+-- @+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
+ persistent-relational-record.cabal view
@@ -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
+ src/Database/Persist/Relational.hs view
@@ -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 <taka@himura.jp>+-- Stability   :  experimental+-- Portability :  unknown+--+-- This module works as a bridge between <https://hackage.haskell.org/package/relational-query Haskell Relational Record>+-- and <http://hackage.haskell.org/package/persistent Persistent>.+-- It uses the persistent entities definition instead of obtaining schema from DB at compilation time.+--+-- See: <https://github.com/himura/persistent-relational-record#readme>+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
+ src/Database/Persist/Relational/Instances.hs view
@@ -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"]
+ src/Database/Persist/Relational/TH.hs view
@@ -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
+ src/Database/Persist/Relational/ToPersistEntity.hs view
@@ -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'
+ stack.yaml view
@@ -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: []
+ tests/Fixtures/BlogSample/Model.hs view
@@ -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+|]
+ tests/Fixtures/BlogSample/Post.hs view
@@ -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+
+ tests/Fixtures/BlogSample/PostTag.hs view
@@ -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+
+ tests/Fixtures/BlogSample/Tag.hs view
@@ -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+
+ tests/Fixtures/BlogSample/User.hs view
@@ -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+
+ tests/hlint.hs view
@@ -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"
+ tests/unit.hs view
@@ -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]