Convert URI (ie: `postgresql://scott:tiger@localhost:5432/mydatabase`) into postgresql-simple ConnectInfo (with prisms).

URIToConnect.hs

module URIToConnect (connectInfo,
                     connectInfoToURI,
                     uri,
                     uriToConnectInfo) where
import Control.Applicative ((<|>), empty)
import Control.Lens hiding (noneOf, uncons)            -- from: lens
import Control.Monad (replicateM)
import Data.ByteString.Base16.Lazy (decode)            -- from: base16-bytestring
import Data.ByteString.Builder as BSB                  -- from: bytestring
import Data.ByteString.Lazy (ByteString)               -- from: bytestring
import qualified Data.ByteString.Lazy as BS            -- from: bytestring
import Data.ByteString.Lazy.Char8 (uncons, unpack)     -- from: bytestring
import Data.Foldable (find)
import Data.Monoid ((<>), Any(..))
import Data.Word (Word16)
import Database.PostgreSQL.Simple (ConnectInfo(..),
                                   defaultConnectInfo) -- from: postgresql-simple
import Network.URI hiding (unreserved)                 -- from: network-uri
import Text.Parsec (many, many1, digit, char,
                    eof, option, parse, satisfy)       -- from: parsec
import Text.Parsec.Char (hexDigit, oneOf)              -- from: parsec
import Text.Parsec.String (Parser)                     -- from: parsec

{-

  λ> postgreSQLConnectionString <$> "postgresql://scott:tiger@localhost/mydatabase" ^? uri . connectInfo
  Just "host='localhost' port=5432 user='scott' password='tiger' dbname='mydatabase'"
  
  λ> review connectInfo <$> "postgresql://scott:tiger@localhost/mydatabase" ^? uri . connectInfo
  Just postgresql://scott:...@localhost:5432/mydatabase 

-}

newtype DBName = DBName { getDBName :: String } deriving (Eq, Show)

data URIError = UnknownScheme String
              | NoAuthInfo
              | NoDatabase -- not used
  deriving (Eq, Show)

-- conversion

uriToConnectInfo :: URI -> Either URIError ConnectInfo
uriToConnectInfo u = do
  case u ^. _uriScheme of
    "postgresql:" -> return ()
    unknown       -> Left $ UnknownScheme unknown
  uauth  <- maybe (Left NoAuthInfo) Right $ u ^. _uriAuthority
  return $ defaultConnectInfo & _connectHost     .~* uauth ^. _uriRegName
                              & _connectPort     .~? uauth ^? _uriPort . port
                              & _connectUser     .~? uauth ^? _uriUserInfo . unpw . _1
                              & _connectPassword .~? uauth ^? _uriUserInfo . unpw . _2
                              & _connectDatabase .~? u     ^? _uriPath . dbName . coerced

connectInfoToURI :: ConnectInfo -> URI
connectInfoToURI cinfo =
  let cred = (cinfo ^. _connectUser, cinfo ^. _connectPassword) ^. re unpw
      auth = emptyURIAuth & _uriUserInfo .~ cred
                          & _uriRegName  .~ (cinfo ^. _connectHost)
                          & _uriPort     .~ (cinfo ^. _connectPort . re port)
  in emptyURI & _uriScheme    .~ "postgresql:"
              & _uriAuthority ?~ auth
              & _uriPath      .~ (cinfo ^. _connectDatabase . coerced . re dbName)

-- prisms

connectInfo :: Prism' URI ConnectInfo
connectInfo = prism' connectInfoToURI $ either (const Nothing) Just . uriToConnectInfo

uri :: Prism' String URI
uri = prism' p parseURI
  where p s = uriToString id s ""

-- internal prisms

port :: Prism' String Word16
port = prism' q p
  where q i = ':' : show i
        p   = either (const Nothing) Just . parse (parsePort <* eof) ""

dbName :: Prism' String DBName
dbName = prism' q p
  where p             = either (const Nothing) Just . parse (parseDBName <* eof) ""
        q (DBName nm) = buildString $ charUtf8 '/' <> encodeChars toPctEncoded [
          isUnreserved, isSubDelims, (`elem` (":@" :: String))] nm

unpw :: Prism' String (String, String)
unpw = prism' q p
  where q (a, b) = buildString $ f a <> r b <> charUtf8 '@'
        f = encodeChars toPctEncoded [isUnreserved, isSubDelims]
        g = encodeChars toPctEncoded [isUnreserved, isSubDelims, (== ':')]
        p = either (const Nothing) Just . parse (parseUNPW <* eof) ""
        r s | null s    = mempty
            | otherwise = charUtf8 ':' <> g s

-- empty values for creating new URI values w/ lenses

emptyURI :: URI
emptyURI = URI "" Nothing "" "" ""

emptyURIAuth :: URIAuth
emptyURIAuth = URIAuth "" "" ""

-- some new lens operators for dealing with empty values

(.~?) :: ASetter' s a -> Maybe a -> s -> s
_ .~? Nothing = id
f .~? Just  x = f .~ x
infixr 4 .~?

(.~*) :: (Eq a, Monoid a) => ASetter' s a -> a -> s -> s
f .~* a | a == mempty = id
        | otherwise   = f .~ a
infixr 4 .~*

-- parsing strings

parsePort :: Parser Word16
parsePort = char ':' *> (read <$> many1 digit)

parseUNPW :: Parser (String, String)
parseUNPW =  go <* char '@'
  where go        = (,) <$> many authpart <*> option "" pw
        pw        = char ':' *> many authpart'
        authpart  = unreserved <|> pctEncoded
        authpart' = authpart <|> char ':'

unreserved :: Parser Char
unreserved = satisfy isUnreserved

pctEncoded :: Parser Char
pctEncoded = let x = char '%' *> replicateM 2 hexDigit
                 y = fmap fst . (>>= uncons) . filterPartialDecode . decode . BSB.toLazyByteString . BSB.stringUtf8 <$> x
             in y >>= maybe empty return
  where filterPartialDecode :: (a, ByteString) -> Maybe a
        filterPartialDecode s = const (fst s) <$> find BS.null s

subDelimChars :: String -- helps with overloaded strings and elem
subDelimChars = "!$&'()*+,;="

subDelims :: Parser Char
subDelims = oneOf subDelimChars

isSubDelims :: Char -> Bool
isSubDelims c = c `elem` subDelimChars


pChar :: Parser Char
pChar = unreserved <|> pctEncoded <|> subDelims <|> oneOf ":@"

parseDBName :: Parser DBName
parseDBName = char '/' *> (DBName <$> many1 pChar)

-- building strings

buildString :: Builder -> String
buildString = unpack . BSB.toLazyByteString

toPctEncoded :: Char -> Builder
toPctEncoded = pctEveryByte . lazify . builder
  where builder = BSB.lazyByteStringHex . lazify . BSB.charUtf8
        lazify  = BSB.toLazyByteString

encodeChars :: (Char -> Builder) -> [Char -> Bool] -> String -> Builder
encodeChars f preds = foldr step mempty
  where p        = fmap getAny . mconcat $ fmap (fmap Any) preds
        step c r = if p c then charUtf8 c <> r else f c <> r

pctEveryByte :: ByteString -> Builder
pctEveryByte s = let (a, b) = BS.splitAt 2 s
                 in if BS.null a
                    then mempty
                    else BSB.charUtf8 '%' <> BSB.lazyByteString a <> pctEveryByte b

--- let's make some lenses for our external types
--- can probably do these with template haskell and some options

_uriScheme :: Lens' URI String
_uriScheme = lens uriScheme $ \s r -> s { uriScheme = r }

_uriAuthority :: Lens' URI (Maybe URIAuth)
_uriAuthority = lens uriAuthority $ \s r -> s { uriAuthority = r }

_uriPath :: Lens' URI String
_uriPath = lens uriPath $ \s r -> s { uriPath = r }

_uriQuery :: Lens' URI String
_uriQuery = lens uriQuery $ \s r -> s { uriQuery = r }

_uriFragment :: Lens' URI String
_uriFragment = lens uriFragment $ \s r -> s { uriFragment = r }

_uriUserInfo :: Lens' URIAuth String
_uriUserInfo = lens uriUserInfo $ \s r -> s { uriUserInfo = r }

_uriRegName :: Lens' URIAuth String
_uriRegName = lens uriRegName $ \s r -> s { uriRegName = r }

_uriPort :: Lens' URIAuth String
_uriPort = lens uriPort $ \s r -> s { uriPort = r }

_connectHost :: Lens' ConnectInfo String
_connectHost = lens connectHost $ \s r -> s { connectHost = r }

_connectPort :: Lens' ConnectInfo Word16
_connectPort = lens connectPort $ \s r -> s { connectPort = r }

_connectUser :: Lens' ConnectInfo String
_connectUser = lens connectUser $ \s r -> s { connectUser = r }

_connectPassword :: Lens' ConnectInfo String
_connectPassword = lens connectPassword $ \s r -> s { connectPassword = r }

_connectDatabase :: Lens' ConnectInfo String
_connectDatabase = lens connectDatabase $ \s r -> s { connectDatabase = r }