{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, OverloadedStrings, Rank2Types, GeneralizedNewtypeDeriving, RecordWildCards #-}
module Hc2Prosody.Users (Users, User, jabberID, JID) where

import BasicPrelude
import Control.DeepSeq (NFData)
import Control.Lens
import Control.Monad.Trans.Maybe (runMaybeT)
import Data.Aeson
import Data.Aeson.Lens
import Data.Aeson.TH
import Data.Aeson.Types
import Data.DeriveTH
import Data.Foldable
import Data.HipChat.JSON
import Data.Maybe (fromJust)
import Data.Text (pack, unpack)
import Hc2Prosody.JID

newtype User = User { _email :: Maybe Text } deriving (NFData)

newtype Users = Users { _users :: IntMap User } deriving (NFData)

derive makeMonoid ''Users

makeLenses ''User
deriveJSON (defaultOptions {fieldLabelModifier = tail}) ''User
makeLenses ''Users

user :: Int -> Lens' Users (Maybe User)
user i = users . at i

data EmailAddr = EmailAddr { username :: Text, domain :: Text }

instance Read EmailAddr where
  readsPrec _ s = let (u,d) = break (== '@') s
                  in case d of [] -> []
                               (_:t) -> [(EmailAddr { username = pack u, domain = pack t }, "")]

jabberID :: Text -> Users -> Int -> Maybe JID
jabberID rootHost u i = emailAddrToJID . read <$> (jabberUser i u)^.email
  where
    emailAddrToJID (EmailAddr{..}) = mkJID username rootHost

instance FromJSON Users where
  parseJSON (Array vs) = foldlM (\acc -> fmap (acc <>) . parseUserObj) mempty vs
    where
      parseUserObj :: Value -> Parser Users
      parseUserObj v = do
        (actualObj, parsedUser) <- maybe (fail "Expected object labelled User") return =<< runMaybeT (parseLabelled "User" v)
        userID <- maybe (fail "Cannot determine user ID") return $ actualObj^? key "id" . _Integral
        return $ mempty & user userID ?~ parsedUser
  parseJSON _ = fail "Expected array"

jabberUser :: Int -> Users -> User
jabberUser i = fromJust . (^. user i)
