module HsKu.Web where

import HsKu
import HsKu.Config
import HsKu.JSON
import qualified Data.Text as T
import Data.Text (Text)
import Data.String
import Data.Map ((!))
import Data.Aeson
import Servant as S
import Network.HTTP.Simple
import Control.Monad
import Control.Monad.IO.Class
import GHC.Generics

type Name     = Text
type Channel  = Text
data MMsg     = MMsg
  { MMsg -> Text
text          :: Text
  , MMsg -> Text
user_name     :: Name
  , MMsg -> Text
channel_name  :: Channel
  } deriving (MMsg -> MMsg -> Bool
(MMsg -> MMsg -> Bool) -> (MMsg -> MMsg -> Bool) -> Eq MMsg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MMsg -> MMsg -> Bool
== :: MMsg -> MMsg -> Bool
$c/= :: MMsg -> MMsg -> Bool
/= :: MMsg -> MMsg -> Bool
Eq, Int -> MMsg -> ShowS
[MMsg] -> ShowS
MMsg -> String
(Int -> MMsg -> ShowS)
-> (MMsg -> String) -> ([MMsg] -> ShowS) -> Show MMsg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MMsg -> ShowS
showsPrec :: Int -> MMsg -> ShowS
$cshow :: MMsg -> String
show :: MMsg -> String
$cshowList :: [MMsg] -> ShowS
showList :: [MMsg] -> ShowS
Show, (forall x. MMsg -> Rep MMsg x)
-> (forall x. Rep MMsg x -> MMsg) -> Generic MMsg
forall x. Rep MMsg x -> MMsg
forall x. MMsg -> Rep MMsg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MMsg -> Rep MMsg x
from :: forall x. MMsg -> Rep MMsg x
$cto :: forall x. Rep MMsg x -> MMsg
to :: forall x. Rep MMsg x -> MMsg
Generic)

instance FromJSON MMsg

data MPost = MPost
  { MPost -> Text
chn :: Channel
  , MPost -> Text
msg :: Text
  } deriving (MPost -> MPost -> Bool
(MPost -> MPost -> Bool) -> (MPost -> MPost -> Bool) -> Eq MPost
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MPost -> MPost -> Bool
== :: MPost -> MPost -> Bool
$c/= :: MPost -> MPost -> Bool
/= :: MPost -> MPost -> Bool
Eq, Int -> MPost -> ShowS
[MPost] -> ShowS
MPost -> String
(Int -> MPost -> ShowS)
-> (MPost -> String) -> ([MPost] -> ShowS) -> Show MPost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MPost -> ShowS
showsPrec :: Int -> MPost -> ShowS
$cshow :: MPost -> String
show :: MPost -> String
$cshowList :: [MPost] -> ShowS
showList :: [MPost] -> ShowS
Show, (forall x. MPost -> Rep MPost x)
-> (forall x. Rep MPost x -> MPost) -> Generic MPost
forall x. Rep MPost x -> MPost
forall x. MPost -> Rep MPost x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. MPost -> Rep MPost x
from :: forall x. MPost -> Rep MPost x
$cto :: forall x. Rep MPost x -> MPost
to :: forall x. Rep MPost x -> MPost
Generic)

instance ToJSON MPost where
  toJSON :: MPost -> Value
toJSON = Options -> MPost -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
defaultOptions {fieldLabelModifier :: ShowS
fieldLabelModifier = ShowS
forall {a}. (Eq a, IsString a) => a -> a
flm}
    where flm :: a -> a
flm a
"msg" = a
"text"
          flm a
"chn" = a
"channel_name"
          flm a
other = a
other

praise :: Name -> Channel -> Haiku -> MPost
praise :: Text -> Text -> Haiku -> MPost
praise Text
n Text
c (Text
h1,Text
h2,Text
h3) = Text -> Text -> MPost
MPost Text
c (Text -> MPost) -> Text -> MPost
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
  (Text
"@" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 🥳 Haiku gefunden!\n") Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text
h1,Text
h2,Text
h3]

type API = "haiku"        :> QueryParam' '[Required] "input" Text
                          :> Get '[JSON] HaikuResult
      :<|>  "mattermost"  :> ReqBody '[JSON] MMsg :> PostNoContent

server :: Config -> Languages -> Server API
server :: Config -> Languages -> Server API
server Config
cfg Languages
langs = Text -> Handler HaikuResult
handleHaiku (Text -> Handler HaikuResult)
-> (MMsg -> Handler NoContent)
-> (Text -> Handler HaikuResult) :<|> (MMsg -> Handler NoContent)
forall a b. a -> b -> a :<|> b
:<|> MMsg -> Handler NoContent
handleMattermost
  where

      handleHaiku :: Text -> Handler HaikuResult
      handleHaiku :: Text -> Handler HaikuResult
handleHaiku Text
t = do
        let mhaiku :: Maybe Haiku
mhaiku = (Language, Haiku) -> Haiku
forall a b. (a, b) -> b
snd ((Language, Haiku) -> Haiku)
-> Maybe (Language, Haiku) -> Maybe Haiku
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Languages -> Text -> Maybe (Language, Haiku)
parseHaiku Languages
langs Text
t
        HaikuResult -> Handler HaikuResult
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (HaikuResult -> Handler HaikuResult)
-> HaikuResult -> Handler HaikuResult
forall a b. (a -> b) -> a -> b
$ Maybe Haiku -> HaikuResult
HaikuResult Maybe Haiku
mhaiku

      handleMattermost :: MMsg -> Handler NoContent
      handleMattermost :: MMsg -> Handler NoContent
handleMattermost MMsg
m = do
        Maybe Haiku -> (Haiku -> Handler ()) -> Handler ()
forall {a}. Maybe a -> (a -> Handler ()) -> Handler ()
whenMaybeM ((Language, Haiku) -> Haiku
forall a b. (a, b) -> b
snd ((Language, Haiku) -> Haiku)
-> Maybe (Language, Haiku) -> Maybe Haiku
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Languages -> Text -> Maybe (Language, Haiku)
parseHaiku Languages
langs (MMsg -> Text
text MMsg
m)) ((Haiku -> Handler ()) -> Handler ())
-> (Haiku -> Handler ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \Haiku
haiku -> do
          let jpraise :: MPost
jpraise = Text -> Text -> Haiku -> MPost
praise (MMsg -> Text
user_name MMsg
m) (MMsg -> Text
channel_name MMsg
m) Haiku
haiku
              request :: Request
request = String -> Request
forall a. IsString a => String -> a
fromString (String -> Request) -> String -> Request
forall a b. (a -> b) -> a -> b
$ Config
cfg Config -> String -> Map String String
forall k a. Ord k => Map k a -> k -> a
! String
"mattermost" Map String String -> ShowS
forall k a. Ord k => Map k a -> k -> a
! String
"post-url"
              postReq :: Request
postReq = ByteString -> Request -> Request
setRequestMethod ByteString
"POST" Request
request
              jsonReq :: Request
jsonReq = MPost -> Request -> Request
forall a. ToJSON a => a -> Request -> Request
setRequestBodyJSON MPost
jpraise Request
postReq
          Handler (Response ()) -> Handler ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handler (Response ()) -> Handler ())
-> Handler (Response ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ IO (Response ()) -> Handler (Response ())
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Request -> IO (Response ())
forall (m :: * -> *). MonadIO m => Request -> m (Response ())
httpNoBody Request
jsonReq)
        NoContent -> Handler NoContent
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return NoContent
NoContent
        where whenMaybeM :: Maybe a -> (a -> Handler ()) -> Handler ()
whenMaybeM = ((a -> Handler ()) -> Maybe a -> Handler ())
-> Maybe a -> (a -> Handler ()) -> Handler ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> Handler ()) -> Maybe a -> Handler ())
 -> Maybe a -> (a -> Handler ()) -> Handler ())
-> ((a -> Handler ()) -> Maybe a -> Handler ())
-> Maybe a
-> (a -> Handler ())
-> Handler ()
forall a b. (a -> b) -> a -> b
$ Handler () -> (a -> Handler ()) -> Maybe a -> Handler ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Handler () -> (a -> Handler ()) -> Maybe a -> Handler ())
-> Handler () -> (a -> Handler ()) -> Maybe a -> Handler ()
forall a b. (a -> b) -> a -> b
$ () -> Handler ()
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

hskuWebService :: Config -> Languages -> Application
hskuWebService :: Config -> Languages -> Application
hskuWebService Config
cfg Languages
langs = Proxy API -> Server API -> Application
forall {k} (api :: k).
HasServer api '[] =>
Proxy api -> Server api -> Application
serve Proxy API
api (Server API -> Application) -> Server API -> Application
forall a b. (a -> b) -> a -> b
$ Config -> Languages -> Server API
server Config
cfg Languages
langs
  where api :: Proxy API
api = Proxy API
forall {k} (t :: k). Proxy t
S.Proxy :: S.Proxy API