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
import Text.PCLT.MakeCatalog
import Text.PCLT.CatalogFromHSRT
import System.IO
import System.IO.Unsafe
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"
}
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
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
(\ _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
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
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)
data DropFlag_CatalogNeedsToBeUpdated_Error =
NotModified_DFCNTBUE
| DBError_DFCNTBUE SqlError
deriving (Show, Typeable)
data AddressedDropFlag_CatalogNeedsToBeUpdated_Error = AddressedDropFlag_CatalogNeedsToBeUpdated_Error DropFlag_CatalogNeedsToBeUpdated_Error PCLT_CatalogID deriving (Show, Typeable)
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
)
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)
emptyCUE :: CatalogUpdateFromDBErrors -> Bool
emptyCUE cue = foldr (\ p_f accum -> accum && p_f cue) True [isNothing . cueDropCNTBUFlag, isNothing . cueARFDBE, null . cueCatReadErrs, null . cueCollectionErrs, cueCatalogRead]
defaultCatalogUpdateFromDBErrors :: PCLT_CatalogID -> CatalogUpdateFromDBErrors
defaultCatalogUpdateFromDBErrors cat_id = CatalogUpdateFromDBErrors {
cueDropCNTBUFlag = Nothing
, cueARFDBE = Nothing
, cueCatReadErrs = []
, cueCollectionErrs = []
, cueCatalogID = cat_id
, cueCatalogRead = False
}
cfhie2cue :: CatalogFromHSRTInitErrors -> CatalogUpdateFromDBErrors
cfhie2cue cfhie = (defaultCatalogUpdateFromDBErrors $ cfhieCatalogID cfhie) {
cueCatReadErrs = cfhieCatReadErrs cfhie
, cueCollectionErrs = cfhieCollectionErrs cfhie
, cueCatalogRead = True
}
___always_update = False
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)
)