Tables.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2015 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE FlexibleInstances          #-}

module Coin.DB.Tables where

import qualified Data.Text as T
import qualified Data.Binary as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL

import System.Directory
import Control.Monad
import Data.Int
import Data.ByteString (ByteString)
import Database.Persist.Sqlite
import Database.Persist.TH

import Coin.DB.Functions
import Coin.Utils.I18N
import Coin.Config.Dirs

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
TagsTable json
    name String
    deriving Show

AccountsTable json
    name String
    balance Int64
    deriving Show

OperationsTable json
    date Int
    from AccountsTableId
    to AccountsTableId
    value Int
    tag TagsTableId
    description String
    deriving Show

ReservedTable
    en String
    ref Int64

AccountsOptionsTable
    indexes ByteString
|]

instance B.Binary AccountsTableId where
    put accountsID =
        case toPersistValue accountsID of
            PersistInt64 val -> B.put val
            _                -> error "Tables.hs: Binary AccountsTableId: something went wrong."
    get = do
        val <- B.get :: B.Get Int64
        case fromPersistValue $ PersistInt64 val of
            Right val' -> return val'
            Left err   -> error $ "Tables.hs: Binary AccountsTableId: Error: " ++ T.unpack err

accountsOptionsTableUpdate :: [AccountsTableId] -> IO ()
accountsOptionsTableUpdate accountIDs = do
    let blob = BL.toStrict . B.encode $ accountIDs
    runDB $ do
        options <- selectList [] []
        case options of
            []                   -> void $ insert $ AccountsOptionsTable blob
            [Entity optionsID _] -> replace optionsID $ AccountsOptionsTable blob
            _                    -> error "Tables.hs: accountsOptionsTableUpdate: something went wrong."

accountsOptionsTableRead :: IO [AccountsTableId]
accountsOptionsTableRead =
    runDB $ do
        option <- selectFirst [] []
        case option of
            Just (Entity _ (AccountsOptionsTable blob)) -> return $ B.decode . BB.toLazyByteString . BB.byteString $ blob
            Nothing -> return []

checkReservedID :: PersistField a => String -> (String -> IO a) -> IO a
checkReservedID name insertAction = do
    reserved <- runDB $ selectFirst [ ReservedTableEn ==. name] []

    case reserved of
        Just (Entity _ entity) ->
            case fromPersistValue $ PersistInt64 $ reservedTableRef entity of
                Right val -> return val
                Left err -> error $ "Tables.hs: Error: " ++ T.unpack err

        Nothing -> do
            tableID <- insertAction $ __ name

            case toPersistValue tableID of
                PersistInt64 val -> void $ runDB $ insert $ ReservedTable name val
                _                -> error "Tables.hs: Something went wrong."

            return tableID

tagsTableNoneID :: IO TagsTableId
tagsTableNoneID = checkReservedID "None" $ \name -> runDB $ insert $ TagsTable name

accountsTableIncomeID :: IO AccountsTableId
accountsTableIncomeID = checkReservedID "Income" $ \name -> runDB $ insert $ AccountsTable name 0

accountsTableOutcomeID :: IO AccountsTableId
accountsTableOutcomeID = checkReservedID "Outcome" $ \name -> runDB $ insert $ AccountsTable name 0

accountsTableCashID :: IO AccountsTableId
accountsTableCashID = checkReservedID "Cash" $ \name -> runDB $ insert $ AccountsTable name 0

initializeDatabase :: IO ()
initializeDatabase = do
    dir <- configGetDirectory
    createDirectoryIfMissing True dir

    runDB $ runMigration migrateAll

    void tagsTableNoneID
    void accountsTableIncomeID
    void accountsTableOutcomeID
    void accountsTableCashID

tagsTableSelectAll :: IO [Entity TagsTable]
tagsTableSelectAll = runDB $ selectList [] []

tagsTableSelectAllNames :: IO [String]
tagsTableSelectAllNames = do
    list <- tagsTableSelectAll
    return $
        map (\(Entity _ tag) -> tagsTableName tag) list

tagsTableSelectID :: String -> IO TagsTableId
tagsTableSelectID tagName = do
    (Just (Entity tagID _)) <- runDB $ selectFirst [ TagsTableName ==. tagName ] []
    return tagID

tagsTableSelectName :: TagsTableId -> IO String
tagsTableSelectName tagID = do
    (Just (Entity _ tagEntity))  <- runDB $ selectFirst [ TagsTableId ==. tagID ] []
    return $ tagsTableName tagEntity

accountsTableSelectAll :: IO [Entity AccountsTable]
accountsTableSelectAll = runDB $ selectList [] []

accountsTableSelectAllNames :: IO [String]
accountsTableSelectAllNames = do
    list <- accountsTableSelectAll
    return $
        map (\(Entity _ account) -> accountsTableName account) list

accountsTableSelectID :: String -> IO AccountsTableId
accountsTableSelectID accountName = do
    (Just (Entity accountID _)) <- runDB $ selectFirst [ AccountsTableName ==. accountName ] []
    return accountID

accountsTableSelectName :: AccountsTableId -> IO String
accountsTableSelectName accountID = do
    (Just (Entity _ accountEntity))  <- runDB $ selectFirst [ AccountsTableId ==. accountID ] []
    return $ accountsTableName accountEntity

accountsTableSelectBalance :: AccountsTableId -> IO Int64
accountsTableSelectBalance accountID = do
    (Just (Entity _ account)) <- runDB $ selectFirst [AccountsTableId ==. accountID] []
    return $ accountsTableBalance account

operationsTableSelectList :: Int -> Int -> IO [Entity OperationsTable]
operationsTableSelectList from to = runDB $ selectList [OperationsTableDate >=. from, OperationsTableDate <=. to] []