Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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 }
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement