--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-|
Module: Model.Types.Lms
Description: Types for Learning Management System Interface operated by Know how! AG

-}
module Model.Types.Lms
  ( module Model.Types.Lms 
  ) where

import Import.NoModel
import qualified Data.Map as Map
import Data.Map ((!))
import Database.Persist.Sql 
import qualified Database.Esqueleto.Experimental as E
import qualified Data.Csv as Csv
import qualified Data.Time.Format as Time
import Data.Time.Format.ISO8601 (iso8601ParseM)
import Utils.Lens.TH

newtype LmsIdent = LmsIdent { getLmsIdent :: Text }
  deriving (Eq, Ord, Read, Show, Generic)
  deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql, Csv.ToField, Csv.FromField)
instance E.SqlString LmsIdent 
makeLenses_ ''LmsIdent

deriveJSON defaultOptions
  { constructorTagModifier = camelToPathPiece' 1  
  , fieldLabelModifier = camelToPathPiece' 2
  , omitNothingFields = True  
  } ''LmsIdent 

-- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
-- ...also see similar type QualificationBlocked
data LmsStatus = LmsBlocked { lmsStatusDay :: Day }
               | LmsExpired { lmsStatusDay :: Day }
               | LmsSuccess { lmsStatusDay :: Day }
  deriving (Eq, Read, Show, Generic, NFData)

instance Ord LmsStatus where 
  compare a b
    | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
    , daycmp /= EQ = daycmp    
  compare LmsSuccess{} LmsBlocked{} = GT
  compare LmsSuccess{} LmsExpired{} = GT
  compare LmsBlocked{} LmsSuccess{} = LT
  compare LmsExpired{} LmsSuccess{} = LT 
  compare LmsBlocked{} LmsExpired{} = GT
  compare LmsExpired{} LmsBlocked{} = LT 
  compare _            _            = EQ 

isLmsSuccess :: LmsStatus -> Bool 
isLmsSuccess LmsSuccess{} = True 
isLmsSuccess _other       = False

isLmsExpired :: LmsStatus -> Bool 
isLmsExpired LmsExpired{} = True 
isLmsExpired _other       = False

-- | What to do if LMS sends multiple responses and whether an oldStatus should be overwritten
replaceLmsStatus :: Maybe LmsStatus -> Maybe LmsStatus -> Bool
replaceLmsStatus _ Nothing = False
replaceLmsStatus Nothing _ = True
replaceLmsStatus (Just LmsSuccess{}) _  = False
replaceLmsStatus (Just LmsExpired{}) (Just newStat) = not $ isLmsExpired newStat
replaceLmsStatus (Just LmsBlocked{}) (Just newStat) = isLmsSuccess newStat

makeLenses_ ''LmsStatus

-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
instance Semigroup LmsStatus where 
  a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess         

deriveJSON  defaultOptions
  { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already
  , fieldLabelModifier     = camelToPathPiece' 2      -- just day suffices for the day field
  , omitNothingFields = True
  , sumEncoding = TaggedObject "lms-status" "lms-result"
  } ''LmsStatus
derivePersistFieldJSON ''LmsStatus

instance Csv.ToField LmsStatus where
  toField (LmsBlocked d) = "Failure: " <> Csv.toField d
  toField (LmsExpired d) = "Expired: " <> Csv.toField d
  toField (LmsSuccess d) = "Success: " <> Csv.toField d

data QualificationBlocked = QualificationBlocked { qualificationBlockedDay    :: Day
                                                 , qualificationBlockedReason :: Text 
                                                 } 
  deriving (Eq, Ord, Read, Show, Generic, NFData)

makeLenses_ ''QualificationBlocked

deriveJSON  defaultOptions
  { tagSingleConstructors = False
  , fieldLabelModifier     = camelToPathPiece' 2
  , omitNothingFields = True  
  } ''QualificationBlocked 
derivePersistFieldJSON ''QualificationBlocked 

instance Csv.ToField QualificationBlocked  where
  toField QualificationBlocked{..} = "Blocked " <> Csv.toField qualificationBlockedDay <> " due to " <> Csv.toField qualificationBlockedReason

-- | ToMessage instance ignores contained timestamp by design
-- instance ToMessage QualificationBlocked where -- no longer used
--   toMessage QualificationBlocked{..} = qualificationBlockedReason

data QualificationBlockStandardReason
      = QualificationBlockFailedELearning
      | QualificationBlockReturnedByCompany
  deriving (Eq, Ord, Enum, Bounded, Universe, Finite)

instance Show QualificationBlockStandardReason where
  show QualificationBlockFailedELearning    = "E-Learning durchgefallen"
  show QualificationBlockReturnedByCompany  = "Rückgabe Firma"

qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
qualificationBlockedReasonText = 
  let dictionary :: Map.Map QualificationBlockStandardReason Text = Map.fromList [(r, tshow r) | r <- universeF]
  in (dictionary !) -- cannot fail due to universeF

mkQualificationBlocked :: QualificationBlockStandardReason -> Day -> QualificationBlocked
mkQualificationBlocked reason qualificationBlockedDay = QualificationBlocked{..}
  where 
    qualificationBlockedReason = qualificationBlockedReasonText reason

-- | LMS interface requires Bool to be encoded by 0 or 1 only
newtype LmsBool = LmsBool { lms2bool :: Bool }
  deriving (Eq, Ord, Read, Show, Generic)

_lmsBool :: Iso' Bool LmsBool
_lmsBool = iso LmsBool lms2bool

instance Csv.ToField LmsBool where 
  toField (LmsBool False) = "0"
  toField (LmsBool True ) = "1"
  
instance Csv.FromField LmsBool where 
  parseField i
    | i == "0"  = pure $ LmsBool False
    | i == "1"  = pure $ LmsBool True 
    | otherwise = mempty

-- | LMS interface requires day format not compliant with iso8601; also LMS uses LOCAL TIMEZONE
newtype LmsDay = LmsDay { lms2day :: Day }
  deriving (Eq, Ord, Read, Show, Generic)

_lmsDay :: Iso' Day LmsDay 
_lmsDay = iso LmsDay lms2day

-- | Format for day for LMS interface
lmsDayFormat :: String 
lmsDayFormat = "%d-%m-%Y" -- fixed in LMS interface desctiption, due defaultTimeLocale, should not use named entities like weekdays or month names

instance Csv.ToField LmsDay where 
  toField (LmsDay d) = Csv.toField $ Time.formatTime Time.defaultTimeLocale lmsDayFormat d -- TimeLocale should not matter since format string does not use names; getTimeLocale requires MonadHandler

instance Csv.FromField LmsDay where 
--  parseField = fmap LmsDay . parseLmsDay <=< Csv.parseField
--    where parseLmsDay = Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat
  parseField i = do 
    s <- Csv.parseField i 
    d <- Time.parseTimeM True Time.defaultTimeLocale lmsDayFormat s
         <|> iso8601ParseM s -- Know-How AG considers supplying iso8601 dates in the future
    return $ LmsDay d
