Postgres error message parser

postgrest.cabal

@@ -26,7 +26,7 @@ executable postgrest
                      , scientific, time
                      , aeson, network >= 2.6
                      , bytestring, text, split, string-conversions
-                     , stringsearch
+                     , stringsearch, parsec
                      , containers, unordered-containers
                      , optparse-applicative >= 0.9.1 && < 0.10
                      , regex-base, regex-tdfa
@@ -44,6 +44,7 @@ executable postgrest
                      , Config
                      , PgStructure
                      , PgQuery
+                     , PgError
                      , RangeQuery
                      , Middleware
   hs-source-dirs:      src
@@ -69,7 +70,7 @@ Test-Suite spec
                      , http-types, scientific, time
                      , bytestring, aeson, network >= 2.6
                      , text, optparse-applicative
-                     , stringsearch
+                     , stringsearch, parsec
                      , unordered-containers
                      , regex-base
                      , string-conversions

src/PgError.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module PgError (Message(..), parseMessage) where
+
+import Text.Parsec
+import Text.Parsec.Text
+import qualified Data.Map as M
+import Data.Text
+
+import Data.String.Conversions (cs)
+import Data.CaseInsensitive (CI, mk)
+
+data Message = Message {
+    msgStatus :: Maybe Text
+  , msgCode   :: Maybe Text
+  , msgText   :: Maybe Text
+  , msgHint   :: Maybe Text
+} deriving (Show)
+
+parseMessage :: Parser Message
+parseMessage = do
+  ps <- sepBy valPair (char ';' >> optional (char ' '))
+  let m = M.fromList ps
+  return $ Message
+    (M.lookup "status" m)
+    (M.lookup "code" m)
+    (M.lookup "message" m)
+    (M.lookup "hint" m)
+
+valPair :: Parser (CI Text, Text)
+valPair = do
+  name <- many1 letter
+  _ <- char ':'
+  optional $ char ' '
+  _ <- char '"'
+  val <- many1 (noneOf "\"")
+  _ <- char '"'
+  return (mk (cs name), cs val)