{-# LANGUAGE CPP #-}

-- | Convenience methods for constructing backend-agnostic applications
module Database.Beam.Backend.URI where

import           Control.Exception

import qualified Data.Map as M

import           Network.URI

data BeamResourceNotFound = BeamResourceNotFound deriving Int -> BeamResourceNotFound -> ShowS
[BeamResourceNotFound] -> ShowS
BeamResourceNotFound -> String
(Int -> BeamResourceNotFound -> ShowS)
-> (BeamResourceNotFound -> String)
-> ([BeamResourceNotFound] -> ShowS)
-> Show BeamResourceNotFound
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BeamResourceNotFound] -> ShowS
$cshowList :: [BeamResourceNotFound] -> ShowS
show :: BeamResourceNotFound -> String
$cshow :: BeamResourceNotFound -> String
showsPrec :: Int -> BeamResourceNotFound -> ShowS
$cshowsPrec :: Int -> BeamResourceNotFound -> ShowS
Show
instance Exception BeamResourceNotFound

data BeamOpenURIInvalid = BeamOpenURIInvalid deriving Int -> BeamOpenURIInvalid -> ShowS
[BeamOpenURIInvalid] -> ShowS
BeamOpenURIInvalid -> String
(Int -> BeamOpenURIInvalid -> ShowS)
-> (BeamOpenURIInvalid -> String)
-> ([BeamOpenURIInvalid] -> ShowS)
-> Show BeamOpenURIInvalid
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BeamOpenURIInvalid] -> ShowS
$cshowList :: [BeamOpenURIInvalid] -> ShowS
show :: BeamOpenURIInvalid -> String
$cshow :: BeamOpenURIInvalid -> String
showsPrec :: Int -> BeamOpenURIInvalid -> ShowS
$cshowsPrec :: Int -> BeamOpenURIInvalid -> ShowS
Show
instance Exception BeamOpenURIInvalid

data BeamOpenURIUnsupportedScheme = BeamOpenURIUnsupportedScheme String deriving Int -> BeamOpenURIUnsupportedScheme -> ShowS
[BeamOpenURIUnsupportedScheme] -> ShowS
BeamOpenURIUnsupportedScheme -> String
(Int -> BeamOpenURIUnsupportedScheme -> ShowS)
-> (BeamOpenURIUnsupportedScheme -> String)
-> ([BeamOpenURIUnsupportedScheme] -> ShowS)
-> Show BeamOpenURIUnsupportedScheme
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BeamOpenURIUnsupportedScheme] -> ShowS
$cshowList :: [BeamOpenURIUnsupportedScheme] -> ShowS
show :: BeamOpenURIUnsupportedScheme -> String
$cshow :: BeamOpenURIUnsupportedScheme -> String
showsPrec :: Int -> BeamOpenURIUnsupportedScheme -> ShowS
$cshowsPrec :: Int -> BeamOpenURIUnsupportedScheme -> ShowS
Show
instance Exception BeamOpenURIUnsupportedScheme

data BeamURIOpener c where
  BeamURIOpener :: c be hdl m
                -> (forall a. hdl -> m a -> IO a)
                -> (URI -> IO (hdl, IO ()))
                -> BeamURIOpener c
newtype BeamURIOpeners c where
  BeamURIOpeners :: M.Map String (BeamURIOpener c) -> BeamURIOpeners c

instance Semigroup (BeamURIOpeners c) where
  BeamURIOpeners Map String (BeamURIOpener c)
a <> :: BeamURIOpeners c -> BeamURIOpeners c -> BeamURIOpeners c
<> BeamURIOpeners Map String (BeamURIOpener c)
b =
    Map String (BeamURIOpener c) -> BeamURIOpeners c
forall (c :: * -> * -> (* -> *) -> *).
Map String (BeamURIOpener c) -> BeamURIOpeners c
BeamURIOpeners (Map String (BeamURIOpener c)
a Map String (BeamURIOpener c)
-> Map String (BeamURIOpener c) -> Map String (BeamURIOpener c)
forall a. Semigroup a => a -> a -> a
<> Map String (BeamURIOpener c)
b)

instance Monoid (BeamURIOpeners c) where
  mempty :: BeamURIOpeners c
mempty = Map String (BeamURIOpener c) -> BeamURIOpeners c
forall (c :: * -> * -> (* -> *) -> *).
Map String (BeamURIOpener c) -> BeamURIOpeners c
BeamURIOpeners Map String (BeamURIOpener c)
forall a. Monoid a => a
mempty
  mappend :: BeamURIOpeners c -> BeamURIOpeners c -> BeamURIOpeners c
mappend = BeamURIOpeners c -> BeamURIOpeners c -> BeamURIOpeners c
forall a. Semigroup a => a -> a -> a
(<>)

data OpenedBeamConnection c where
  OpenedBeamConnection
    :: { ()
beamRunner          :: (forall a. hdl -> m a -> IO a)
       , ()
openedBeamDatabase  :: c be hdl m
       , ()
openedBeamHandle    :: hdl
       , OpenedBeamConnection c -> IO ()
closeBeamConnection :: IO ()
     } -> OpenedBeamConnection c

mkUriOpener :: (forall a. hdl -> m a -> IO a)
            -> String
            -> (URI -> IO (hdl, IO ()))
            -> c be hdl m
            -> BeamURIOpeners c
mkUriOpener :: (forall a. hdl -> m a -> IO a)
-> String
-> (URI -> IO (hdl, IO ()))
-> c be hdl m
-> BeamURIOpeners c
mkUriOpener forall a. hdl -> m a -> IO a
runner String
schemeNm URI -> IO (hdl, IO ())
opener c be hdl m
c = Map String (BeamURIOpener c) -> BeamURIOpeners c
forall (c :: * -> * -> (* -> *) -> *).
Map String (BeamURIOpener c) -> BeamURIOpeners c
BeamURIOpeners (String -> BeamURIOpener c -> Map String (BeamURIOpener c)
forall k a. k -> a -> Map k a
M.singleton String
schemeNm (c be hdl m
-> (forall a. hdl -> m a -> IO a)
-> (URI -> IO (hdl, IO ()))
-> BeamURIOpener c
forall (c :: * -> * -> (* -> *) -> *) be hdl (m :: * -> *).
c be hdl m
-> (forall a. hdl -> m a -> IO a)
-> (URI -> IO (hdl, IO ()))
-> BeamURIOpener c
BeamURIOpener c be hdl m
c forall a. hdl -> m a -> IO a
runner URI -> IO (hdl, IO ())
opener))

withDbFromUri :: forall c a
               . BeamURIOpeners c
              -> String
              -> (forall be hdl m. (forall r. hdl -> m r -> IO r) -> c be hdl m -> m a)
              -> IO a
withDbFromUri :: BeamURIOpeners c
-> String
-> (forall be hdl (m :: * -> *).
    (forall r. hdl -> m r -> IO r) -> c be hdl m -> m a)
-> IO a
withDbFromUri BeamURIOpeners c
protos String
uri forall be hdl (m :: * -> *).
(forall r. hdl -> m r -> IO r) -> c be hdl m -> m a
actionWithDb =
  BeamURIOpeners c
-> String
-> (forall be hdl (m :: * -> *).
    (forall r. hdl -> m r -> IO r) -> c be hdl m -> hdl -> IO a)
-> IO a
forall (c :: * -> * -> (* -> *) -> *) a.
BeamURIOpeners c
-> String
-> (forall be hdl (m :: * -> *).
    (forall r. hdl -> m r -> IO r) -> c be hdl m -> hdl -> IO a)
-> IO a
withDbConnection BeamURIOpeners c
protos String
uri (\forall r. hdl -> m r -> IO r
runner c be hdl m
c hdl
hdl -> hdl -> m a -> IO a
forall r. hdl -> m r -> IO r
runner hdl
hdl ((forall r. hdl -> m r -> IO r) -> c be hdl m -> m a
forall be hdl (m :: * -> *).
(forall r. hdl -> m r -> IO r) -> c be hdl m -> m a
actionWithDb forall r. hdl -> m r -> IO r
runner c be hdl m
c))

withDbConnection :: forall c a
                  . BeamURIOpeners c
                 -> String
                 -> (forall be hdl m. (forall r. hdl -> m r -> IO r) ->
                      c be hdl m -> hdl -> IO a)
                 -> IO a
withDbConnection :: BeamURIOpeners c
-> String
-> (forall be hdl (m :: * -> *).
    (forall r. hdl -> m r -> IO r) -> c be hdl m -> hdl -> IO a)
-> IO a
withDbConnection BeamURIOpeners c
protos String
uri forall be hdl (m :: * -> *).
(forall r. hdl -> m r -> IO r) -> c be hdl m -> hdl -> IO a
actionWithDb =
  IO (OpenedBeamConnection c)
-> (OpenedBeamConnection c -> IO ())
-> (OpenedBeamConnection c -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (BeamURIOpeners c -> String -> IO (OpenedBeamConnection c)
forall (c :: * -> * -> (* -> *) -> *).
BeamURIOpeners c -> String -> IO (OpenedBeamConnection c)
openDbConnection BeamURIOpeners c
protos String
uri) OpenedBeamConnection c -> IO ()
forall (c :: * -> * -> (* -> *) -> *).
OpenedBeamConnection c -> IO ()
closeBeamConnection ((OpenedBeamConnection c -> IO a) -> IO a)
-> (OpenedBeamConnection c -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$
  \(OpenedBeamConnection forall a. hdl -> m a -> IO a
runner c be hdl m
c hdl
hdl IO ()
_) -> (forall a. hdl -> m a -> IO a) -> c be hdl m -> hdl -> IO a
forall be hdl (m :: * -> *).
(forall r. hdl -> m r -> IO r) -> c be hdl m -> hdl -> IO a
actionWithDb forall a. hdl -> m a -> IO a
runner c be hdl m
c hdl
hdl

openDbConnection :: forall c
                  . BeamURIOpeners c
                 -> String
                 -> IO (OpenedBeamConnection c)
openDbConnection :: BeamURIOpeners c -> String -> IO (OpenedBeamConnection c)
openDbConnection BeamURIOpeners c
protos String
uri = do
  (URI
parsedUri, BeamURIOpener c be hdl m
c forall a. hdl -> m a -> IO a
runner URI -> IO (hdl, IO ())
openURI) <- BeamURIOpeners c -> String -> IO (URI, BeamURIOpener c)
forall (c :: * -> * -> (* -> *) -> *).
BeamURIOpeners c -> String -> IO (URI, BeamURIOpener c)
findURIOpener BeamURIOpeners c
protos String
uri
  (hdl
hdl, IO ()
closeHdl) <- URI -> IO (hdl, IO ())
openURI URI
parsedUri
  OpenedBeamConnection c -> IO (OpenedBeamConnection c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((forall a. hdl -> m a -> IO a)
-> c be hdl m -> hdl -> IO () -> OpenedBeamConnection c
forall hdl (m :: * -> *) (c :: * -> * -> (* -> *) -> *) be.
(forall a. hdl -> m a -> IO a)
-> c be hdl m -> hdl -> IO () -> OpenedBeamConnection c
OpenedBeamConnection forall a. hdl -> m a -> IO a
runner c be hdl m
c hdl
hdl IO ()
closeHdl)

findURIOpener :: BeamURIOpeners c -> String -> IO (URI, BeamURIOpener c)
findURIOpener :: BeamURIOpeners c -> String -> IO (URI, BeamURIOpener c)
findURIOpener (BeamURIOpeners Map String (BeamURIOpener c)
protos) String
uri =
  case String -> Maybe URI
parseURI String
uri of
    Maybe URI
Nothing -> BeamOpenURIInvalid -> IO (URI, BeamURIOpener c)
forall e a. Exception e => e -> IO a
throwIO BeamOpenURIInvalid
BeamOpenURIInvalid
    Just URI
parsedUri ->
      case String -> Map String (BeamURIOpener c) -> Maybe (BeamURIOpener c)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (URI -> String
uriScheme URI
parsedUri) Map String (BeamURIOpener c)
protos of
        Maybe (BeamURIOpener c)
Nothing -> BeamOpenURIUnsupportedScheme -> IO (URI, BeamURIOpener c)
forall e a. Exception e => e -> IO a
throwIO (String -> BeamOpenURIUnsupportedScheme
BeamOpenURIUnsupportedScheme (URI -> String
uriScheme URI
parsedUri))
        Just BeamURIOpener c
opener -> (URI, BeamURIOpener c) -> IO (URI, BeamURIOpener c)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI
parsedUri, BeamURIOpener c
opener)