PCLT-DB-0.1: Database/PCLT/InterfaceWithDB.hs
{-
Copyright (C) 2009 Andrejs Sisojevs <andrejs.sisojevs@nextmail.ru>
All rights reserved.
For license and copyright information, see the file COPYRIGHT
-}
--------------------------------------------------------------------------
--------------------------------------------------------------------------
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, TypeSynonymInstances, DeriveDataTypeable #-}
-- | Some instances of 'Database.ReadableFromDB.ReadableFromDB' for reading
-- PCLT catalog and related objects from DB.
--
-- DBMS is PostgreSQL v8.4. Not earlier, since PCLT-DB relies on a feature that
-- appeared in PostgresSQL only in v8.4. - the @WITH@ clause for @SELECT@ query
-- (also @WITH RECURSIVE@).
module Database.PCLT.InterfaceWithDB where
import Control.Exception
import Control.Monad
import Data.Char
import Data.List
import qualified Data.Map as M
import Data.Map (Map, (!))
import Data.Maybe (isNothing)
import Data.MyHelpers
import Data.Either
import Data.Typeable
import Database.HDBC
import Database.HDBC.PostgreSQL
import Database.ReadableFromDB
import Text.PCLT
import Text.PCLT.Config -- for Haddock
import Text.PCLT.MakeCatalog
import Text.PCLT.CatalogFromHSRT
import System.IO
import System.IO.Unsafe
-- * Instances of ReadableFromDB
instance ReadableFromDB PCLT_InnerConfig PCLT_CatalogID where
readFromDB db_conn cat_id = handleSql
(\ exc -> return $ wrapParseResult_Nrows cat_id $ liftInList $ Left $ RecieveError_RFDBE (exc :: SqlError))
(do stmt <- prepare db_conn "SELECT * FROM sch_pcltcatalogs.by_catalog_used_config(?)"
i <- execute stmt [toSql cat_id]
raw_rows <- fetchAllRowsMap' stmt
mapM (parseDBrow db_conn cat_id) raw_rows
)
parseDBrow db_conn cat_id _row_map = liftM (wrapParseResult_1row cat_id) $ do
let so_f_name = "StrictOrient_ofParamsAndCmpsts_onDfltLngTplsSets"
let loc_takeFieldValue f = takeUFieldValue f (uppercaseMapKeys _row_map)
excpt_or_so <- try (evaluate $ read $ loc_takeFieldValue so_f_name)
return $ case excpt_or_so of
Left e -> Left $ RowParseError_RFDBE $ SomeException $ ErrorCall ("Field '" ++ so_f_name ++ "' of Text.PCLT.Config.PCLT_InnerConfig row parse failed! Lower level exception: " ++ show (e :: SomeException))
Right so -> Right $
defaultPCLTInnerConfig {
pcsInnerConfigID = loc_takeFieldValue "tplscat_inner_config_id"
, pcsCompositePlaceholderWrapper = loc_takeFieldValue "CompositePlaceholderWrapper"
, pcsParameterPlaceholderWrapper = loc_takeFieldValue "ParameterPlaceholderWrapper"
, pcsInsuficientDetLevelPlaceholder = loc_takeFieldValue "InsuficientDetLevelPlaceholder"
, pcsMarkingErrorPlaceholderWrapper = loc_takeFieldValue "MarkingErrorPlaceholderWrapper"
, pcsStrictOrient_ofParamsAndCmpsts_onDfltLngTplsSets
= so
, pcsAllowUntemplatedMessages = loc_takeFieldValue "AllowUntemplatedMessages"
, pcsAllowUntemplatedLocalizationsOfMessages
= loc_takeFieldValue "AllowUntemplatedLocalizationsOfMessages"
, pcsShowAdhocParamsInResultOfUntemplated
= loc_takeFieldValue "ShowAdhocParamsInResultOfUntemplated"
, pcsDefaultLanguage = loc_takeFieldValue "DefaultLanguage"
, pcsReparsingDepthMax = loc_takeFieldValue "ReparsingDepthMax"
, pcsReparseParameterContentMaxSize = loc_takeFieldValue "ReparseParameterContentMaxSize"
, pcsInstaniationResultMaxSize = loc_takeFieldValue "InstaniationResultMaxSize"
, pcsAllowEmptySDL_parseItByModusMargin
= loc_takeFieldValue "AllowEmptySDL_parseItByModusMargin"
, pcsAllowUnreadableSDL_parseIdByModusMargin
= loc_takeFieldValue "AllowUnreadableSDL_parseIdByModusMargin"
, pcsNewlineLBS = loc_takeFieldValue "Newline"
}
-- | Container for data, that is read from DB, that goes on input to
-- catalog formation routine.
newtype RawCatalogDataReadFromDBResult = RawCatalogDataReadFromDBResult (PCLT_RawCatalogData, [AddPCLT_toPCLT_Error]) deriving (Show, Typeable)
instance ReadableFromDB RawCatalogDataReadFromDBResult (PCLT_CatalogID, PCLT_InnerConfig) where
readFromDB db_conn (cat_id, cfg) = handleSql
(\ exc -> return $ wrapParseResult_Nrows cat_id $ liftInList $ Left $ RecieveError_RFDBE (exc :: SqlError)) $
do let query = "SELECT pclt_id,tpl_req_sdl,lng,structured_text FROM sch_pcltcatalogs.in_catalog_localized_tpls_with_their_sdls(?) ORDER BY pclt_id"
stmt <- prepare db_conn query -- ORDER BY pclt_id is obligate
i <- execute stmt [toSql cat_id]
raw_rows <- fetchAllRowsMap stmt
let f remaining_rows (tpls_accum, errs_accum) =
case remaining_rows of
[] -> (tpls_accum, errs_accum)
(h:t) ->
let tpl_id = takeFieldValue "pclt_id" h
req_sdl = str2PCLT_SDL Required_SDLM (takeFieldValue "tpl_req_sdl" h) cfg
(rows_by_tpl_id, new_remaining_rows) = span (\ _row -> takeFieldValue "pclt_id" _row == tpl_id) t
(of_wrong_sdls, raw_localizations) = partitionEithers $ map --traceCond (tpl_id == "HW" || tpl_id == "E_PCLT_P2TE") 5 "***" $ watchCond (tpl_id == "HW" || tpl_id == "E_PCLT_P2TE") $
(\ _row -> let sdl2_raw = takeFieldValue "tpl_req_sdl" _row
sdl2 = str2PCLT_SDL Required_SDLM sdl2_raw cfg
in case req_sdl == sdl2 of
True -> Right ( takeFieldValue "lng" _row, takeFieldValue "structured_text" _row )
False -> Left sdl2
)
(h : rows_by_tpl_id)
in f new_remaining_rows
( M.insert tpl_id (M.fromList raw_localizations, req_sdl) tpls_accum
, errs_accum ++ map (\ sdl2 -> DifferentSDLs_APTTPTE $ DifferentSDLs_PCLTE tpl_id (req_sdl, sdl2) ) of_wrong_sdls
)
let (raw_data_map, errs) = f raw_rows (M.empty, [])
return $ liftInList $ wrapParseResult_1row (cat_id, cfg) $ Right $ RawCatalogDataReadFromDBResult (PCLT_RawCatalogData raw_data_map, errs)
parseDBrow _ _ _ = undefined -- doesn't fit for complex cases...
-- | Container for PCLT catalog, that is read from DB.
newtype CatalogReadFromDBResult = CatalogReadFromDBResult (PCLT_Catalog, [ErrorWithPCSCatalog ReadPCSCatalogError], [AddPCLT_toPCLT_Error]) deriving (Show, Typeable)
instance ReadableFromDB CatalogReadFromDBResult PCLT_CatalogID where
readFromDB db_conn cat_id = do
err_or_inner_cfg <- readOneFromDB db_conn cat_id True
case err_or_inner_cfg of
Left err -> return [wrapParseResult_1row cat_id $ Left $ SubReadError_RFDBE err]
Right inner_cfg -> do
err_or_raw_cat_data <- readOneFromDB db_conn (cat_id, inner_cfg) True
return $ liftInList $ wrapParseResult_1row cat_id $
case err_or_raw_cat_data of
Left err -> Left $ SubReadError_RFDBE err
Right (RawCatalogDataReadFromDBResult (raw_cat_data, collection_errors)) -> Right $
let (cat, parse_errs) = readPCLTCatalog inner_cfg cat_id raw_cat_data
in CatalogReadFromDBResult (cat, parse_errs, collection_errors)
parseDBrow _ _ _ = undefined -- doesn't fit for complex cases...
------------------------------------------------------------------------
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Container for a flag, that is read from DB.
--
-- For each catalog in DB there is stored a special flag \"catalog data
-- or config changed\". The flag gets raised by an army of triggers,
-- that watches every table, and is thought to get dropped by a program,
-- which uses DB catalog. Drop the flag right before catalog update
-- from DB.
--
-- Unfortunately, the current implementation of this flagging system
-- constraints the number of agents that update their catalogs from DB
-- by only one (because, when agent updates it's catalog, it drops
-- the flag, and other agents don't know that flag was risen, so they
-- can't know if version of catalog in their operative memory is older
-- then in DB or is it not).
--
-- But this limitation removal is planned as a first ToDo in the next
-- version of PCLT-DB.
newtype CatalogNeedsToBeUpdated_DoesIt = CatalogNeedsToBeUpdated_DoesIt Bool deriving (Typeable,Show)
instance ReadableFromDB CatalogNeedsToBeUpdated_DoesIt PCLT_CatalogID where
readFromDB db_conn cat_id = handleSql
(\ exc -> return $ wrapParseResult_Nrows cat_id $ liftInList $ Left $ RecieveError_RFDBE (exc :: SqlError))
(do stmt <- prepare db_conn "SELECT cat_new_version_available FROM sch_pcltcatalogs.tpls_catalogs WHERE tpls_catalog_id = ?"
i <- execute stmt [toSql cat_id]
raw_rows <- fetchAllRowsMap' stmt
mapM (parseDBrow db_conn cat_id) raw_rows
)
parseDBrow db_conn cat_id row_map =
return $ wrapParseResult_1row cat_id $ Right $ CatalogNeedsToBeUpdated_DoesIt $ (takeFieldValue "cat_new_version_available" row_map)
-- * Drop flag \"catalog data or config changed\" in DB
-- | Errors that may occur, when performing 'dropFlag_CatalogNeedsToBeUpdated'.
data DropFlag_CatalogNeedsToBeUpdated_Error =
NotModified_DFCNTBUE
| DBError_DFCNTBUE SqlError
deriving (Show, Typeable)
-- | Wrapper around 'DropFlag_CatalogNeedsToBeUpdated_Error',
-- added 'PCLT_CatalogID', for which \"drop flag\" operation failed.
data AddressedDropFlag_CatalogNeedsToBeUpdated_Error = AddressedDropFlag_CatalogNeedsToBeUpdated_Error DropFlag_CatalogNeedsToBeUpdated_Error PCLT_CatalogID deriving (Show, Typeable)
-- | Drop that flag in DB.
dropFlag_CatalogNeedsToBeUpdated :: Connection -> PCLT_CatalogID -> IO (Maybe AddressedDropFlag_CatalogNeedsToBeUpdated_Error)
dropFlag_CatalogNeedsToBeUpdated db_conn cat_id =
handleSql
(\ exc -> return $ Just $ AddressedDropFlag_CatalogNeedsToBeUpdated_Error (DBError_DFCNTBUE (exc :: SqlError)) cat_id )
(do r <- run db_conn "UPDATE sch_pcltcatalogs.tpls_catalogs SET cat_new_version_available = FALSE WHERE tpls_catalog_id = ?" [toSql cat_id]
commit db_conn
return $ case r > 0 of
True -> Nothing
False -> Just $ AddressedDropFlag_CatalogNeedsToBeUpdated_Error NotModified_DFCNTBUE cat_id
)
-- * Consider catalog update
-- | The container for all types of errors that may result, when trying
-- to update a catalog from DB.
data CatalogUpdateFromDBErrors =
CatalogUpdateFromDBErrors {
cueDropCNTBUFlag :: Maybe AddressedDropFlag_CatalogNeedsToBeUpdated_Error
, cueARFDBE :: Maybe AddressedReadFromDBError
, cueCatReadErrs :: [ErrorWithPCSCatalog ReadPCSCatalogError]
, cueCollectionErrs :: [AddPCLT_toPCLT_Error]
, cueCatalogID :: PCLT_CatalogID
, cueCatalogRead :: Bool
}
deriving (Show, Typeable)
-- | Checks if catalog is read without a single error.
emptyCUE :: CatalogUpdateFromDBErrors -> Bool
emptyCUE cue = foldr (\ p_f accum -> accum && p_f cue) True [isNothing . cueDropCNTBUFlag, isNothing . cueARFDBE, null . cueCatReadErrs, null . cueCollectionErrs, cueCatalogRead]
-- | An empty form to be filled.
defaultCatalogUpdateFromDBErrors :: PCLT_CatalogID -> CatalogUpdateFromDBErrors
defaultCatalogUpdateFromDBErrors cat_id = CatalogUpdateFromDBErrors {
cueDropCNTBUFlag = Nothing
, cueARFDBE = Nothing
, cueCatReadErrs = []
, cueCollectionErrs = []
, cueCatalogID = cat_id
, cueCatalogRead = False
}
-- | There is a one way relation from
-- 'Text.PCLT.CatalogFromHSRT.CatalogFromHSRTInitErrors'
-- to 'CatalogUpdateFromDBErrors'. That's because subject operations are
-- similar it their abstractions.
cfhie2cue :: CatalogFromHSRTInitErrors -> CatalogUpdateFromDBErrors
cfhie2cue cfhie = (defaultCatalogUpdateFromDBErrors $ cfhieCatalogID cfhie) {
cueCatReadErrs = cfhieCatReadErrs cfhie
, cueCollectionErrs = cfhieCollectionErrs cfhie
, cueCatalogRead = True
}
___always_update = False
-- | Check if the flag \"catalog data or config changed\" is up in DB.
-- If so, drop it and try to read from DB
--
-- (1) 'Text.PCLT.Config.PCLT_InnerConfig'
--
-- (2) 'RawCatalogDataReadFromDBResult'
--
-- (3) 'CatalogReadFromDBResult'
considerCatalogUpdate :: Connection -> PCLT_CatalogID -> IO (Maybe PCLT_Catalog, Maybe CatalogUpdateFromDBErrors)
considerCatalogUpdate db_conn cat_id = do
err_or_newversion_thereis <- readOneFromDB db_conn cat_id True
case err_or_newversion_thereis of
Left arfdbe -> return (Nothing, Just $ ((defaultCatalogUpdateFromDBErrors cat_id) { cueARFDBE = Just arfdbe }))
Right (CatalogNeedsToBeUpdated_DoesIt newversion_thereis) ->
case newversion_thereis || ___always_update of
False -> return (Nothing, Nothing)
True -> do
mb_err <- dropFlag_CatalogNeedsToBeUpdated db_conn cat_id
let mb_cue = case mb_err of
Just dropflag_err -> Just $ ((defaultCatalogUpdateFromDBErrors cat_id) { cueDropCNTBUFlag = mb_err })
Nothing -> Nothing
readCat mb_cue
where
readCat mb_cue = do
err_or_cat <- readOneFromDB db_conn cat_id True
return $ case err_or_cat of
Left arfdbe ->
( Nothing
, liftM (\ cue -> cue { cueARFDBE = Just arfdbe } ) $ Just $ maybe (defaultCatalogUpdateFromDBErrors cat_id) id mb_cue
)
Right (CatalogReadFromDBResult (cat, cat_read_errs_list, collection_errs)) ->
( Just cat
, case null cat_read_errs_list && null collection_errs of
True -> (\ cue -> cue { cueCatalogRead = True } ) `liftM` mb_cue
False -> liftM (\ cue -> cue { cueCatalogRead = True
, cueCatReadErrs = cat_read_errs_list
, cueCollectionErrs = collection_errs
}
)
(Just $ maybe (defaultCatalogUpdateFromDBErrors cat_id) id mb_cue)
)