{-# language RecordWildCards #-}

-- TODO doc
-- Helper parser that works with ByteString, 
-- not Decode
module Database.PostgreSQL.Protocol.Parsers 
    ( parseServerVersion
    , parseIntegerDatetimes
    , parseErrorDesc
    , parseNoticeDesc
    , parseCommandResult
    ) where

import Data.Char                    (chr)
import Data.Maybe                   (fromMaybe)
import Data.Monoid                  ((<>))
import Text.Read                    (readMaybe)

import Data.ByteString.Char8 as BS  (readInteger, readInt, unpack, pack)
import qualified Data.ByteString as B
import qualified Data.HashMap.Strict as HM

import Database.PostgreSQL.Protocol.Types

-- Helper to parse
parseServerVersion :: B.ByteString -> Either B.ByteString ServerVersion
parseServerVersion bs =
    let (numbersStr, desc) = B.span isDigitDot bs
        numbers = readMaybe . BS.unpack <$> B.split 46 numbersStr
    in case numbers ++ repeat (Just 0) of
        (Just major : Just minor : Just rev : _) ->
            Right $ ServerVersion major minor rev desc
        _ -> Left $ "Unknown server version" <> bs
  where
    isDigitDot c | c == 46           = True -- dot
                 | c >= 48 && c < 58 = True -- digits
                 | otherwise         = False

-- Helper to parse
parseIntegerDatetimes :: B.ByteString -> Either B.ByteString Bool
parseIntegerDatetimes  bs
    | bs == "on" || bs == "yes" || bs == "1" = Right True
    | otherwise                              = Right False

parseCommandResult :: B.ByteString -> Either B.ByteString CommandResult
parseCommandResult s =
    let (command, rest) = B.break (== space) s
    in case command of
        -- format: `INSERT oid rows`
        "INSERT" ->
            maybe (Left "Invalid format in INSERT command result") Right $ do
                (oid, r) <- readInteger $ B.dropWhile (== space) rest
                (rows, _) <- readInteger $ B.dropWhile (== space) r
                Just $ InsertCompleted (Oid $ fromInteger oid)
                                       (RowsCount $ fromInteger rows)
        "DELETE" -> DeleteCompleted <$> readRows rest
        "UPDATE" -> UpdateCompleted <$> readRows rest
        "SELECT" -> SelectCompleted <$> readRows rest
        "MOVE"   -> MoveCompleted   <$> readRows rest
        "FETCH"  -> FetchCompleted  <$> readRows rest
        "COPY"   -> CopyCompleted   <$> readRows rest
        _        -> Right CommandOk
  where
    space = 32
    readRows = maybe (Left "Invalid rows format in command result")
                       (pure . RowsCount . fromInteger . fst)
                       . readInteger . B.dropWhile (== space)

parseErrorNoticeFields
    :: B.ByteString -> Either B.ByteString (HM.HashMap Char B.ByteString)
parseErrorNoticeFields = Right . HM.fromList
    . fmap (\s -> (chr . fromIntegral $ B.head s, B.tail s))
    . filter (not . B.null) . B.split 0

parseErrorSeverity :: B.ByteString -> Either B.ByteString ErrorSeverity
parseErrorSeverity bs = Right $ case bs of
    "ERROR" -> SeverityError
    "FATAL" -> SeverityFatal
    "PANIC" -> SeverityPanic
    _       -> UnknownErrorSeverity

parseNoticeSeverity :: B.ByteString -> Either B.ByteString NoticeSeverity
parseNoticeSeverity bs = Right $ case bs of
    "WARNING" -> SeverityWarning
    "NOTICE"  -> SeverityNotice
    "DEBUG"   -> SeverityDebug
    "INFO"    -> SeverityInfo
    "LOG"     -> SeverityLog
    _         -> UnknownNoticeSeverity

parseErrorDesc :: B.ByteString -> Either B.ByteString ErrorDesc
parseErrorDesc s = do
    hm               <- parseErrorNoticeFields s
    errorSeverityOld <- lookupKey 'S' hm
    errorCode        <- lookupKey 'C' hm
    errorMessage     <- lookupKey 'M' hm
    -- This is identical to the S field except that the contents are
    -- never localized. This is present only in messages generated by
    -- PostgreSQL versions 9.6 and later.
    let errorSeverityNew  = HM.lookup 'V' hm
    errorSeverity         <- parseErrorSeverity $
                            fromMaybe errorSeverityOld errorSeverityNew
    let
        errorDetail           = HM.lookup 'D' hm
        errorHint             = HM.lookup 'H' hm
        errorPosition         = HM.lookup 'P' hm >>= fmap fst . readInt
        errorInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
        errorInternalQuery    = HM.lookup 'q' hm
        errorContext          = HM.lookup 'W' hm
        errorSchema           = HM.lookup 's' hm
        errorTable            = HM.lookup 't' hm
        errorColumn           = HM.lookup 'c' hm
        errorDataType         = HM.lookup 'd' hm
        errorConstraint       = HM.lookup 'n' hm
        errorSourceFilename   = HM.lookup 'F' hm
        errorSourceLine       = HM.lookup 'L' hm >>= fmap fst . readInt
        errorSourceRoutine    = HM.lookup 'R' hm
    Right ErrorDesc{..}
  where
    lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
                         "is not presented in ErrorResponse message")
                         Right . HM.lookup c

parseNoticeDesc :: B.ByteString -> Either B.ByteString NoticeDesc
parseNoticeDesc s = do
    hm                <- parseErrorNoticeFields s
    noticeSeverityOld <- lookupKey 'S' hm
    noticeCode        <- lookupKey 'C' hm
    noticeMessage     <- lookupKey 'M' hm
    -- This is identical to the S field except that the contents are
    -- never localized. This is present only in messages generated by
    -- PostgreSQL versions 9.6 and later.
    let noticeSeverityNew = HM.lookup 'V' hm
    noticeSeverity        <- parseNoticeSeverity $
                            fromMaybe noticeSeverityOld noticeSeverityNew
    let
        noticeDetail           = HM.lookup 'D' hm
        noticeHint             = HM.lookup 'H' hm
        noticePosition         = HM.lookup 'P' hm >>= fmap fst . readInt
        noticeInternalPosition = HM.lookup 'p' hm >>= fmap fst . readInt
        noticeInternalQuery    = HM.lookup 'q' hm
        noticeContext          = HM.lookup 'W' hm
        noticeSchema           = HM.lookup 's' hm
        noticeTable            = HM.lookup 't' hm
        noticeColumn           = HM.lookup 'c' hm
        noticeDataType         = HM.lookup 'd' hm
        noticeConstraint       = HM.lookup 'n' hm
        noticeSourceFilename   = HM.lookup 'F' hm
        noticeSourceLine       = HM.lookup 'L' hm >>= fmap fst . readInt
        noticeSourceRoutine    = HM.lookup 'R' hm
    Right NoticeDesc{..}
  where
    lookupKey c = maybe (Left $ "Neccessary key " <> BS.pack (show c) <>
                         "is not presented in NoticeResponse message")
                         Right . HM.lookup c
