QueryExamplesSpec.hs

{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving    #-}

module SQLDB.Tests.QueryExamplesSpec where


import           Data.Aeson (encode)
import qualified Data.ByteString.Lazy as BSL
import           Data.Time
import           EulerHS.Prelude hiding (getOption)
import           Test.Hspec hiding (runIO)
import           Unsafe.Coerce

import           EulerHS.Interpreters
import           EulerHS.Language
import           EulerHS.Runtime (withFlowRuntime)
import           EulerHS.Types hiding (error)

import qualified EulerHS.Language as L
import qualified EulerHS.Runtime as R
import qualified EulerHS.Types as T

import           Database.Beam ((&&.), (/=.), (<-.), (<.), (==.), (>.), (>=.))
import qualified Database.Beam as B
import qualified Database.Beam.Backend.SQL as B
import qualified Database.Beam.Sqlite as BS


date1 :: LocalTime
date1 =  LocalTime
  { localDay = toEnum 56195
  , localTimeOfDay = defaultTimeOfDay1
  }

defaultTimeOfDay1 :: TimeOfDay
defaultTimeOfDay1 = TimeOfDay
  { todHour = 1
  , todMin = 1
  , todSec  = 1
  }

-- 2012-09-26 18:08:45
date2 :: LocalTime
date2 = LocalTime
  { localDay = toEnum 56196
  , localTimeOfDay = td2
  }

td2 :: TimeOfDay
td2 = TimeOfDay
  { todHour = 18
  , todMin = 8
  , todSec  = 45
  }

date3 :: LocalTime
date3 = LocalTime
  { localDay = toEnum 56190
  , localTimeOfDay = td3
  }

date4 :: LocalTime
date4 = LocalTime
  { localDay = toEnum 56191
  , localTimeOfDay = td3
  }

td3 :: TimeOfDay
td3 = TimeOfDay
  { todHour = 0
  , todMin  = 0
  , todSec  = 0
  }

data MemberT f = Member
    { memberId      :: B.C f Int
    , surName       :: B.C f Text
    , firstName     :: B.C f Text
    , address       :: B.C f Text
    , zipCode       :: B.C f Int
    , telephone     :: B.C f Text
    , recommendedBy :: B.C f (Maybe Int)
    , joinDate      :: B.C f LocalTime
    } deriving (Generic, B.Beamable)

instance B.Table MemberT where
  data PrimaryKey MemberT f =
    MemberId (B.C f Int) deriving (Generic, B.Beamable)
  primaryKey = MemberId . memberId

type Member = MemberT Identity

type MemberId = B.PrimaryKey MemberT Identity

deriving instance Show MemberId
deriving instance Eq MemberId
deriving instance ToJSON MemberId
deriving instance FromJSON MemberId

deriving instance Show Member
deriving instance Eq Member
deriving instance ToJSON Member
deriving instance FromJSON Member


membersEMod :: B.EntityModification
  (B.DatabaseEntity be db) be (B.TableEntity MemberT)
membersEMod = B.modifyTableFields
  B.tableModification
    { memberId = B.fieldNamed "memid"
    , surName = B.fieldNamed "surname"
    , firstName = B.fieldNamed "firstname"
    , address = B.fieldNamed "address"
    , zipCode = B.fieldNamed "zipcode"
    , telephone = B.fieldNamed "telephone"
    , recommendedBy = B.fieldNamed "recommendedby"
    , joinDate = B.fieldNamed "joindate"
    }

data FacilityT f = Facility
    { facilityId         :: B.C f Int
    , name               :: B.C f Text
    , memberCost         :: B.C f Double
    , guestCost          :: B.C f Double
    , initialOutlay      :: B.C f Double
    , monthlyMaintenance :: B.C f Double
    } deriving (Generic, B.Beamable)

instance B.Table FacilityT where
  data PrimaryKey FacilityT f =
    FacrId (B.C f Int) deriving (Generic, B.Beamable)
  primaryKey = FacrId . facilityId

type Facility = FacilityT Identity

type FacrId = B.PrimaryKey FacilityT Identity

deriving instance Show FacrId
deriving instance Eq FacrId
deriving instance ToJSON FacrId
deriving instance FromJSON FacrId

deriving instance Show Facility
deriving instance Eq Facility
deriving instance ToJSON Facility
deriving instance FromJSON Facility

facilitiesEMod :: B.EntityModification
  (B.DatabaseEntity be db) be (B.TableEntity FacilityT)
facilitiesEMod = B.modifyTableFields
  B.tableModification
    { facilityId = B.fieldNamed "facid"
    , name = B.fieldNamed "name"
    , memberCost = B.fieldNamed "membercost"
    , guestCost = B.fieldNamed "guestcost"
    , initialOutlay = B.fieldNamed "initialoutlay"
    , monthlyMaintenance = B.fieldNamed "monthlymaintenance"
    }


data BookingT f = Booking
    { bookId    :: B.C f Int
    , facId     :: B.PrimaryKey FacilityT f
    , bmemid    :: B.PrimaryKey MemberT f
    , starttime :: B.C f LocalTime
    , slots     :: B.C f Int
    } deriving (Generic, B.Beamable)

instance B.Table BookingT where
  data PrimaryKey BookingT f =
    BookId (B.C f Int) deriving (Generic, B.Beamable)
  primaryKey = BookId . bookId

type Booking = BookingT Identity

type BookId = B.PrimaryKey BookingT Identity

deriving instance Show Booking
deriving instance Eq Booking
deriving instance ToJSON Booking
deriving instance FromJSON Booking

bookingsEMod :: B.EntityModification
  (B.DatabaseEntity be db) be (B.TableEntity BookingT)
bookingsEMod = B.modifyTableFields
  B.tableModification
    { bookId = B.fieldNamed "bookid"
    , facId = FacrId (B.fieldNamed "facid")
    , bmemid = MemberId (B.fieldNamed "memid")
    , starttime = B.fieldNamed "starttime"
    , slots = B.fieldNamed "slots"
    }


data ClubDB f = ClubDB
    { members    :: f (B.TableEntity MemberT)
    , facilities :: f (B.TableEntity FacilityT)
    , bookings   :: f (B.TableEntity BookingT)
    } deriving (Generic, B.Database be)

clubDB :: B.DatabaseSettings be ClubDB
clubDB = B.defaultDbSettings `B.withDbModification`
  B.dbModification
    { facilities = facilitiesEMod
    , members = membersEMod
    , bookings = bookingsEMod
    }

testDBName :: String
testDBName = "./testDB/SQLDB/TestData/test.db"

testDBTemplateName :: String
testDBTemplateName = "./testDB/SQLDB/TestData/query_examples.db.template"

poolConfig = T.PoolConfig
  { stripes = 1
  , keepAlive = 10
  , resourcesPerStripe = 50
  }

sqliteCfg = T.mkSQLitePoolConfig "clubSQliteDB" testDBName poolConfig

connectOrFail :: T.DBConfig beM -> Flow (T.SqlConn beM)
connectOrFail cfg = L.initSqlDBConnection cfg >>= \case
    Left e     -> error $ show e
    Right conn -> pure conn

rmTestDB :: L.Flow ()
rmTestDB = void $ L.runSysCmd $ "rm -f " <> testDBName

prepareTestDB :: L.Flow ()
prepareTestDB = do
  rmTestDB
  void $ L.runSysCmd $ "cp " <> testDBTemplateName <> " " <> testDBName
  pure ()


--Basic string searches
textSearchLike :: L.Flow (T.DBResult [Facility])
textSearchLike = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn
    $ L.findRows
    $ B.select
    $ B.filter_ (\f -> name f `B.like_` "%Tennis%")
    $ B.all_ (facilities clubDB)

-- Matching against multiple possible values
matchMultValues :: L.Flow (T.DBResult [Facility])
matchMultValues = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn
    $ L.findRows
    $ B.select
    $ B.filter_ (\f -> facilityId f `B.in_` [1,5])
    $ B.all_ (facilities clubDB)

searchByDate :: L.Flow (T.DBResult [Member])
searchByDate = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn
    $ L.findRows
    $ B.select
    $ B.filter_ (\m -> joinDate m >=. B.val_ date1)
    $ B.all_ (members clubDB)


-- Removing duplicates, and ordering results
groupDistinctLimit :: L.Flow (T.DBResult [Text])
groupDistinctLimit = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn
    $ L.findRows
    $ B.select
    $ B.limit_ 10
    $ B.nub_
    $ fmap surName
    $ B.orderBy_ (B.asc_ . surName)
    $ B.all_ (members clubDB)

-- Combining results from multiple queries with union
selectWithUnion:: L.Flow (T.DBResult [Text])
selectWithUnion = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn $
    let
      sn = fmap surName
        $ B.all_ (members clubDB)
      n = fmap name
        $ B.all_ (facilities clubDB)
    in L.findRows $ B.select $ B.limit_ 3 $ B.union_ sn n


aggregate1 :: L.Flow (T.DBResult (Maybe LocalTime))
aggregate1 = do
  conn <- connectOrFail sqliteCfg
  res <- L.runDB conn $
    L.findRow $ B.select
    $ B.aggregate_ (\m -> B.max_ (joinDate m ))
    $ B.all_ (members clubDB)
  pure $ join <$> res

aggregate2 :: L.Flow (T.DBResult (Maybe (Text, Text,(LocalTime))))
aggregate2 = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn $
    L.findRow $ B.select $ do
      mdate <- B.aggregate_ (\ms -> ( B.max_ (joinDate ms)))
          $ B.all_ (members clubDB)
      lm <- B.filter_ (\m -> joinDate m ==. B.fromMaybe_ (B.val_ date2) mdate) $ B.all_ (members clubDB)
      pure (firstName lm, surName lm, joinDate lm)


join1 :: L.Flow (T.DBResult [LocalTime])
join1 = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn $
    L.findRows $ B.select $ fmap starttime $  do
        ms <- B.all_ (members clubDB)
        bs <- B.join_ (bookings clubDB) (\book -> bmemid book ==. B.primaryKey ms)
        B.guard_ (firstName ms ==. "David" &&. surName ms ==. "Farrell")
        pure bs

join2 :: L.Flow (T.DBResult [(LocalTime, Text)])
join2 = do
  conn <- connectOrFail sqliteCfg
  L.runDB conn
    $ L.findRows
    $ B.select
    $ B.orderBy_ (B.asc_ . fst)
    $ fmap (\(fs,bs) -> (starttime bs,name fs))
    $ do
      fs <- B.all_ (facilities clubDB)
      bs <- B.join_ (bookings clubDB) (\book -> facId book ==. B.primaryKey fs)
      B.guard_ ( starttime bs >=. (B.val_ date3)
             &&. starttime bs <. (B.val_ date4)
             &&. name fs `B.like_` "%Tennis Court%")
      pure (fs, bs)


loggerCfg = defaultLoggerConfig
        { _logToFile = True
        , _logFilePath = "/tmp/euler-backend.log"
        , _isAsync = True
        }

withEmptyDB :: (R.FlowRuntime -> IO ()) -> IO ()
withEmptyDB act = withFlowRuntime Nothing (\rt -> do
  try (runFlow rt prepareTestDB) >>= \case
    Left (e :: SomeException) ->
      runFlow rt rmTestDB
      `finally` error ("Preparing test values failed: " <> show e)
    Right _ -> act rt `finally` runFlow rt rmTestDB
    )


spec :: Spec
spec =
  around withEmptyDB $

    describe "Query examples" $ do
      it "Text search with 'like' operator " $ \rt -> do
        eRes <- runFlow rt textSearchLike
        eRes `shouldBe` Right [Facility {facilityId = 0, name = "Tennis Court 1", memberCost = 5.0, guestCost = 25.0, initialOutlay = 10000.0, monthlyMaintenance = 200.0},Facility {facilityId = 1, name = "Tennis Court 2", memberCost = 5.0, guestCost = 25.0, initialOutlay = 8000.0, monthlyMaintenance = 200.0},Facility {facilityId = 3, name = "Table Tennis", memberCost = 0.0, guestCost = 5.0, initialOutlay = 320.0, monthlyMaintenance = 10.0}]

      it "Match against mult values" $ \rt -> do
        eRes <- runFlow rt matchMultValues
        eRes `shouldBe` Right [Facility {facilityId = 1, name = "Tennis Court 2", memberCost = 5.0, guestCost = 25.0, initialOutlay = 8000.0, monthlyMaintenance = 200.0},Facility {facilityId = 5, name = "Massage Room 2", memberCost = 35.0, guestCost = 80.0, initialOutlay = 4000.0, monthlyMaintenance = 3000.0}]


      it "search by date" $ \rt -> do
        eRes <- runFlow rt searchByDate
        (length <$> eRes) `shouldBe` Right 1

      it "orderDistinctLimit" $ \rt -> do
        eRes <- runFlow rt groupDistinctLimit
        eRes `shouldBe` Right ["Bader","Baker","Boothe","Butters","Coplin","Crumpet","Dare","Farrell","GUEST","Genting"]

      it "selectWithUnion" $ \rt -> do
        eRes <- runFlow rt selectWithUnion
        eRes `shouldBe` Right ["Bader","Badminton Court","Baker"]

      it "aggregate1" $ \rt -> do
        eRes <- runFlow rt aggregate1
        eRes `shouldBe` Right (Just date2)

      it "aggregate2" $ \rt -> do
        eRes <- runFlow rt aggregate2
        eRes `shouldBe` Right (Just ("Darren","Smith",  date2))

      it "join1" $ \rt -> do
        eRes <- runFlow rt join1
        length <$> eRes `shouldBe` Right 34

      it "join2" $ \rt -> do
        eRes <- runFlow rt join2
        eRes `shouldBe` fmap (sortOn fst) eRes
        length <$> eRes `shouldBe` Right 12