{-# LANGUAGE DataKinds #-}
{-# language QuasiQuotes #-}
{-# options_ghc -Wno-unused-imports #-}
-- | Common functions for the MS Azure API
--
module MSAzureAPI.Internal.Common (
  APIPlane(..)
  -- ** PUT
  , put
  -- ** GET
  , get
  , getBs
  , getLbs
  -- ** POST
  , post
  , postRaw
  , postSBMessage
  -- ** DELETE
  , delete
  -- * HTTP(S) connections
  , run
  , withTLS
  -- ** URL parameters
  , (==:)
  -- ** Helpers
  , tryReq
  -- ** Common types
  , Collection
  , collectionValue
  , collectionNextLink
  -- *** Location
  , Location(..)
  , showLocation
  , locationDisplayName
  -- ** JSON co\/dec
  , aesonOptions
  -- ** misc
  , say
  ) where

import Control.Monad.IO.Class (MonadIO(..))
import Data.Proxy (Proxy)
import GHC.Generics (Generic(..))

import Data.List (sort, sortBy, stripPrefix, uncons)
import Data.Maybe (listToMaybe, fromJust, fromMaybe)
-- import Data.Ord (comparing)
import Data.Char (toLower)

-- aeson
import qualified Data.Aeson as A (ToJSON(..), encode, FromJSON(..), genericParseJSON, defaultOptions, Options(..), withObject, withText, (.:), (.:?), object, (.=), Key, Value(..), camelTo2)
-- bytestring
import qualified Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Char8 as BS8 (pack, unpack)
import qualified Data.ByteString.Lazy as LBS (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LBS8 (pack, unpack, putStrLn)
-- http-client
import Network.HTTP.Client (Manager)
import qualified Network.HTTP.Client as L (RequestBody(..))
-- http-client-tls
import Network.HTTP.Client.TLS (newTlsManager)
-- hoauth2
import Network.OAuth.OAuth2 (OAuth2Token(..))
import Network.OAuth.OAuth2.Internal (AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
-- modern-uri
import Text.URI (URI, mkURI)
-- req
import Network.HTTP.Req (Req, runReq, HttpBody(..), HttpConfig(..), HttpException(..), defaultHttpConfig, req, Option, (=:), GET(..), POST(..), PUT(..), DELETE(..), Url, Scheme(..), urlQ, useHttpsURI, https, (/:), ReqBodyJson(..), NoReqBody(..), oAuth2Bearer, HttpResponse(..), jsonResponse, JsonResponse, lbsResponse, LbsResponse, bsResponse, BsResponse, responseBody)
-- text
import Data.Text (Text, pack, unpack)
-- unliftio
import UnliftIO (MonadUnliftIO(..))
import UnliftIO.Exception (try)

-- | URL parameters
(==:) :: Text -- ^ key
      -> Text -- ^ value
      -> Option 'Https
==: :: Text -> Text -> Option 'Https
(==:) = forall param a.
(QueryParam param, ToHttpApiData a) =>
Text -> a -> param
(=:)

-- | @GET@ a 'LBS.ByteString' e.g. a file
getLbs :: APIPlane
       -> [Text] -- ^ URI path segments
       -> Option 'Https -> AccessToken -> Req LBS.ByteString
getLbs :: APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getLbs APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy LbsResponse
lbsResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

-- | @GET@ a 'BS.ByteString' e.g. a file
getBs :: APIPlane
      -> [Text] -- ^ URI path segments
      -> Option 'Https -> AccessToken -> Req BS.ByteString
getBs :: APIPlane
-> [Text] -> Option 'Https -> AccessToken -> Req ByteString
getBs APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

-- | Create a new TLS manager, which should be reused throughout the program
withTLS :: MonadIO m =>
           (HttpConfig -> Manager -> m b) -- ^ user program
        -> m b
withTLS :: forall (m :: * -> *) b.
MonadIO m =>
(HttpConfig -> Manager -> m b) -> m b
withTLS HttpConfig -> Manager -> m b
act = do
  Manager
mgr <- forall (m :: * -> *). MonadIO m => m Manager
newTlsManager
  let
    hc :: HttpConfig
hc = HttpConfig
defaultHttpConfig { httpConfigAltManager :: Maybe Manager
httpConfigAltManager = forall a. a -> Maybe a
Just Manager
mgr }
  HttpConfig -> Manager -> m b
act HttpConfig
hc Manager
mgr

-- | Run a 'Req' computation
run :: MonadIO m =>
       HttpConfig -> Req a -> m (Either HttpException a)
run :: forall (m :: * -> *) a.
MonadIO m =>
HttpConfig -> Req a -> m (Either HttpException a)
run HttpConfig
hc = forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
hc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Req a -> Req (Either HttpException a)
tryReq


-- | Specialized version of 'try' to 'HttpException's
--
-- This can be used to catch exceptions of composite 'Req' statements, e.g. around a @do@ block
tryReq :: Req a -> Req (Either HttpException a)
tryReq :: forall a. Req a -> Req (Either HttpException a)
tryReq = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try

-- | API control planes
--
-- https://learn.microsoft.com/en-us/azure/azure-resource-manager/management/control-plane-and-data-plane
data APIPlane = APManagement -- ^ Management plane (@management.azure.com@ endpoints)
              | APData Text -- ^ Data plane e.g. FileREST API
              | APServiceBus Text -- ^ Data plane for Service Bus. The parameter is the service name

-- | @PUT@
put :: (A.FromJSON b, A.ToJSON a) =>
       APIPlane
    -> [Text] -- ^ URI path segments
    -> Option 'Https -- ^ request parameters etc.
    -> a -> AccessToken -> Req b
put :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
put APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req PUT
PUT Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

-- | @DELETE@
delete :: (A.FromJSON b, A.ToJSON a) =>
          APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
delete :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
delete APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req DELETE
DELETE Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

-- | @POST@
post :: (A.FromJSON b, A.ToJSON a) =>
        APIPlane
     -> [Text] -- ^ URI path segments
     -> Option 'Https -- ^ request parameters etc.
     -> a -- ^ request body
     -> AccessToken -> Req b
post :: forall b a.
(FromJSON b, ToJSON a) =>
APIPlane -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
post APIPlane
apiplane [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

-- | @POST@ to a URL
--
-- useful when the base URL is dynamic e.g. comes from an external service
postRaw :: (A.FromJSON b, A.ToJSON a) =>
           Text -- ^ base URL (can contain path and parameters too)
        -> [Text] -- ^ additional URI path segments
        -> Option 'Https
        -> a -> AccessToken -> Req b
postRaw :: forall b a.
(FromJSON b, ToJSON a) =>
Text -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
postRaw Text
uraw [Text]
paths Option 'Https
params a
bdy AccessToken
atok = do
  URI
uriBase <- forall (m :: * -> *). MonadThrow m => Text -> m URI
mkURI Text
uraw
  let
    auth :: Option 'Https
auth = AccessToken -> Option 'Https
bearerAuth AccessToken
atok
    (Url 'Https
u, Option scheme
uparams) = forall a. HasCallStack => Maybe a -> a
fromJust (forall (scheme :: Scheme). URI -> Maybe (Url 'Https, Option scheme)
useHttpsURI URI
uriBase)
    url :: Url 'Https
url = Url 'Https
u forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
//: [Text]
paths
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params forall a. Semigroup a => a -> a -> a
<> forall {scheme :: Scheme}. Option scheme
uparams -- NB identical keys are not overwritten
  forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyJson a
ReqBodyJson a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts




-- | Post a message or batch thereof to the Service Bus
--
-- see example : https://learn.microsoft.com/en-us/rest/api/servicebus/send-message-batch#example
postSBMessage :: (A.FromJSON b, A.ToJSON a) =>
                 Text
              -> [Text]
              -> Option 'Https -> a -> AccessToken -> Req b
postSBMessage :: forall b a.
(FromJSON b, ToJSON a) =>
Text -> [Text] -> Option 'Https -> a -> AccessToken -> Req b
postSBMessage Text
servName [Text]
paths Option 'Https
params a
bdy AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req POST
POST Url 'Https
url (forall a. a -> ReqBodyServiceBusMessage a
ReqBodyServiceBusMessage a
bdy) forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig (Text -> APIPlane
APServiceBus Text
servName) [Text]
paths AccessToken
tok

data ReqBodyServiceBusMessage a = ReqBodyServiceBusMessage a
instance A.ToJSON a => HttpBody (ReqBodyServiceBusMessage a) where
  getRequestBody :: ReqBodyServiceBusMessage a -> RequestBody
getRequestBody (ReqBodyServiceBusMessage a
a) = ByteString -> RequestBody
L.RequestBodyLBS (forall a. ToJSON a => a -> ByteString
A.encode a
a)
  getRequestContentType :: ReqBodyServiceBusMessage a -> Maybe ByteString
getRequestContentType ReqBodyServiceBusMessage a
_ = forall a. a -> Maybe a
Just ByteString
"application/vnd.microsoft.servicebus.json"

-- | @GET@
get :: (A.FromJSON b) =>
       APIPlane
    -> [Text] -- ^ URI path segments
    -> Option 'Https -> AccessToken -> Req b
get :: forall b.
FromJSON b =>
APIPlane -> [Text] -> Option 'Https -> AccessToken -> Req b
get APIPlane
apiplane [Text]
paths Option 'Https
params AccessToken
tok = forall response.
HttpResponse response =>
response -> HttpResponseBody response
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody forall a. Proxy (JsonResponse a)
jsonResponse Option 'Https
opts
  where
    opts :: Option 'Https
opts = Option 'Https
auth forall a. Semigroup a => a -> a -> a
<> Option 'Https
params
    (Url 'Https
url, Option 'Https
auth) = APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
paths AccessToken
tok

msAzureReqConfig :: APIPlane
                 -> [Text] -- ^ URI path segments
                 -> AccessToken
                 -> (Url 'Https, Option 'Https)
msAzureReqConfig :: APIPlane -> [Text] -> AccessToken -> (Url 'Https, Option 'Https)
msAzureReqConfig APIPlane
apiplane [Text]
uriRest AccessToken
atok = (Url 'Https
url, Option 'Https
os)
  where
    url :: Url 'Https
url = APIPlane -> [Text] -> Url 'Https
apiPlaneBaseURL APIPlane
apiplane [Text]
uriRest
    os :: Option 'Https
os = AccessToken -> Option 'Https
bearerAuth AccessToken
atok

apiPlaneBaseURL :: APIPlane
                -> [Text] -- ^ URI path segments
                -> Url 'Https
apiPlaneBaseURL :: APIPlane -> [Text] -> Url 'Https
apiPlaneBaseURL APIPlane
apiplane [Text]
uriRest = (Text -> Url 'Https
https Text
urlBase) forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
//: [Text]
uriRest
  where
    urlBase :: Text
urlBase = case APIPlane
apiplane of
      APIPlane
APManagement -> Text
"management.azure.com"
      APData Text
ub -> Text
ub
      APServiceBus Text
sn -> Text
sn forall a. Semigroup a => a -> a -> a
<> Text
".servicebus.windows.net"

bearerAuth :: AccessToken -> Option 'Https
bearerAuth :: AccessToken -> Option 'Https
bearerAuth (AccessToken Text
ttok) = ByteString -> Option 'Https
oAuth2Bearer forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS8.pack (Text -> String
unpack Text
ttok)


(//:) :: Url scheme -> [Text] -> Url scheme
//: :: forall (scheme :: Scheme). Url scheme -> [Text] -> Url scheme
(//:) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
(/:)


-- * common types

-- | Displays the short name, e.g. "westeu"
showLocation :: Location -> Text
showLocation :: Location -> Text
showLocation = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show

-- | Azure regions
data Location =
  LNorthEU -- ^ "North Europe"
  | LWestEU -- ^ "West Europe"
  deriving (Location -> Location -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Location -> Location -> Bool
$c/= :: Location -> Location -> Bool
== :: Location -> Location -> Bool
$c== :: Location -> Location -> Bool
Eq)
instance Show Location where
  show :: Location -> String
show = \case
    Location
LNorthEU -> String
"northeu"
    Location
LWestEU -> String
"westeu"
-- | Renders the full name via 'locationDisplayName'
instance A.ToJSON Location where
  toJSON :: Location -> Value
toJSON = Text -> Value
A.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Location -> Text
locationDisplayName

-- | Displays the full name, e.g. "West Europe"
locationDisplayName :: Location -> Text
locationDisplayName :: Location -> Text
locationDisplayName = \case
  Location
LNorthEU -> Text
"North Europe"
  Location
LWestEU -> Text
"West Europe"

-- | a collection of items with key @value@
--
-- NB : results are paginated, and subsequent chunks can be accessed by following the @nextLink@ field
data Collection a = Collection {
  forall a. Collection a -> [a]
cValue :: [a]
  , forall a. Collection a -> Maybe Text
cNextLink :: Maybe Text -- ^ The URI to fetch the next page of results
                               } deriving (Collection a -> Collection a -> Bool
forall a. Eq a => Collection a -> Collection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Collection a -> Collection a -> Bool
$c/= :: forall a. Eq a => Collection a -> Collection a -> Bool
== :: Collection a -> Collection a -> Bool
$c== :: forall a. Eq a => Collection a -> Collection a -> Bool
Eq, Int -> Collection a -> ShowS
forall a. Show a => Int -> Collection a -> ShowS
forall a. Show a => [Collection a] -> ShowS
forall a. Show a => Collection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Collection a] -> ShowS
$cshowList :: forall a. Show a => [Collection a] -> ShowS
show :: Collection a -> String
$cshow :: forall a. Show a => Collection a -> String
showsPrec :: Int -> Collection a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Collection a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Collection a) x -> Collection a
forall a x. Collection a -> Rep (Collection a) x
$cto :: forall a x. Rep (Collection a) x -> Collection a
$cfrom :: forall a x. Collection a -> Rep (Collection a) x
Generic)
instance A.FromJSON a => A.FromJSON (Collection a) where
  parseJSON :: Value -> Parser (Collection a)
parseJSON = forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
A.genericParseJSON (String -> Options
aesonOptions String
"c")
-- | Get the collection items
collectionValue :: Collection a -> [a]
collectionValue :: forall a. Collection a -> [a]
collectionValue = forall a. Collection a -> [a]
cValue
-- | Get the next link for a 'Collection' of paginated results
collectionNextLink :: Collection a -> Maybe Text
collectionNextLink :: forall a. Collection a -> Maybe Text
collectionNextLink = forall a. Collection a -> Maybe Text
cNextLink

-- * aeson

-- | drop the prefix and lowercase first character
--
-- e.g. @userDisplayName@ @->@ @displayName@
aesonOptions :: String -- ^ record prefix
             -> A.Options
aesonOptions :: String -> Options
aesonOptions String
pfx = Options
A.defaultOptions { fieldLabelModifier :: ShowS
A.fieldLabelModifier = String -> ShowS
recordName String
pfx }

-- | drop the prefix and lowercase first character
recordName :: String -- ^ record name prefix
           -> String -- ^ JSON field name
           -> String
recordName :: String -> ShowS
recordName String
pf String
str = case forall a. [a] -> Maybe (a, [a])
uncons forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [a]
dropPrefix String
pf String
str of
  Just (Char
c, String
cs) -> Char -> Char
toLower Char
c forall a. a -> [a] -> [a]
: String
cs
  Maybe (Char, String)
_ -> forall a. HasCallStack => String -> a
error String
"record name cannot be empty"

-- | Drops the given prefix from a list.
--   It returns the original sequence if the sequence doesn't start with the given prefix.
--
-- > dropPrefix "Mr. " "Mr. Men" == "Men"
-- > dropPrefix "Mr. " "Dr. Men" == "Dr. Men"
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix :: forall a. Eq a => [a] -> [a] -> [a]
dropPrefix [a]
a [a]
b = forall a. a -> Maybe a -> a
fromMaybe [a]
b forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
a [a]
b

say :: MonadIO m => String -> m ()
say :: forall (m :: * -> *). MonadIO m => String -> m ()
say = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn