content: {-# 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
  