{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module Ham.Log
(module Ham.Qso,
logToFile,
logFromFile,
configToFile,
configFromFile,
HamLog,
LogState(..),
emptyLogState,
LogConfigV3(..),
LogConfig(..),
configLogFile,
configQsoDefaults,
defaultConfig,
evalHamLog,
execHamLog,
runHamLog,
readLog,
writeLog,
addQso,
newQsoNow,
fillFromCAT,
updateQso,
deleteQso,
sortLog,
currentUtcTime,
filterCallsign,
isDuplicate,
findQsos,
findDuplicateQsos,
Duplicate(..),
getQsoList,
getQsoSeq,
asks,
cat,
lookupFcc,
lookupFccName,
Log(..),
addQsoToLog,
sortLog_,
emptyLog,
makeCabrillo
) where
import Data.Foldable
import qualified Data.Sequence as S
import Data.Sequence (Seq)
import Data.Time.Calendar
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Text as T
import Data.Sequence
import qualified Data.ByteString.Lazy as B
import Data.Aeson.Encode.Pretty
import Data.Aeson
import Data.Maybe (isJust, fromJust)
import qualified Data.Map as M
import Control.Applicative ((<|>))
import Control.Monad (when)
import Control.Monad.Trans.RWS.Strict
import Control.Monad.IO.Class
import Control.Exception
import Ham.Internal.Log
import Ham.Internal.Log.Config
import Ham.Fcc
import Ham.Cabrillo
import Ham.Qso
import Ham.Data
import qualified Ham.CAT as CAT
import Ham.CAT.Radios
import Lens.Micro.TH
emptyLog :: Log
emptyLog = Log mempty
addQsoToLog :: Log -> Qso -> Log
addQsoToLog l q = l { _logQsos = m }
where m = q <| _logQsos l
sortLog_ :: Ord a => Log -> (Qso -> a) -> Log
sortLog_ l g = l { _logQsos = sortBy f (_logQsos l) }
where f a b = compare (g a) (g b)
logToFile :: Log -> FilePath -> IO ()
logToFile l fp = B.writeFile fp $ encodePretty l
logFromFile :: FilePath -> IO (Maybe Log)
logFromFile fp =
(decode <$> B.readFile fp)
`catch` \(SomeException e) -> return Nothing
type HamLog = RWST LogConfig [Text] LogState IO
data LogState = LogState { _stateLog :: Log
, _stateUseCat :: Bool
, _stateSerialCAT :: Maybe CAT.SerialCAT }
makeLenses ''LogState
emptyLogState :: LogState
emptyLogState = LogState emptyLog True Nothing
initState :: HamLog ()
initState = do
catconf <- asks _configCat
let mserial = M.lookup (CAT.catRadio catconf) serialInterface
s <- get
c <- asks _configUseCat
put s { _stateSerialCAT = mserial
, _stateUseCat = c }
evalHamLog :: LogConfig -> LogState -> HamLog a -> IO (a, [Text])
evalHamLog cfg s act = evalRWST (initState >> act) cfg s
execHamLog :: LogConfig -> LogState -> HamLog a -> IO (LogState, [Text])
execHamLog cfg s act = execRWST (initState >> act) cfg s
runHamLog :: LogConfig -> LogState -> HamLog a -> IO (a, LogState, [Text])
runHamLog cfg s act = runRWST (initState >> act) cfg s
readLog :: HamLog ()
readLog = do
f <- asks _configLogFile
ml <- liftIO $ logFromFile f `catch` \(SomeException a) -> return Nothing
maybe (return ()) (\l -> do { s <- get; put $ s { _stateLog = l } }) ml
writeLog :: HamLog ()
writeLog = do
f <- asks _configLogFile
l <- gets _stateLog
liftIO $ logToFile l f
addQso :: Qso -> HamLog ()
addQso q = do
l <- gets _stateLog
let l' = addQsoToLog l $ sanitizeQso q
modify $ \s -> s { _stateLog = l' }
currentUtcTime :: HamLog UTCTime
currentUtcTime = liftIO $ do
t <- getCurrentTime
let tod = utctDayTime t
tod' = (picosecondsToDiffTime . (\a -> a - a `rem` (10^12)) . diffTimeToPicoseconds) tod
return $ t { utctDayTime = tod' }
newQsoNow :: HamLog Qso
newQsoNow = do
now <- currentUtcTime
defaults <- asks _configQsoDefaults
let q = (qsoWithDefaults defaults)
{ _qsoTimeStart = now
, _qsoTimeEnd = (fromIntegral 60) `addUTCTime` now
}
q' <- fillFromCAT q
addQso q'
return q'
fillFromCAT :: Qso -> HamLog Qso
fillFromCAT qso = do
result <- cat $ do
f <- CAT.catFrequency
m <- CAT.catMode
return (f,m)
case result of
Left (CAT.CATError t s) -> tell [s] >> return qso
Right ((mf, mm), _) -> return $ qso { _qsoFrequency = maybe (_qsoFrequency qso) id mf,
_qsoMode = maybe (_qsoMode qso) id mm }
updateQso :: Int -> Qso -> HamLog ()
updateQso i q = do
l <- gets _stateLog
let q' = update i (sanitizeQso q) $ _logQsos l
modify $ \s -> s { _stateLog = l { _logQsos = q' } }
return ()
deleteQso :: Int -> HamLog ()
deleteQso i = do
l <- gets _stateLog
let q' = deleteAt i $ _logQsos l
modify $ \s -> s { _stateLog = l { _logQsos = q' } }
sortLog :: Ord a => (Qso -> a) -> HamLog ()
sortLog g = do
l <- gets _stateLog
let l' = sortLog_ l g
modify $ \s -> s { _stateLog = l' }
getQsoList :: HamLog [Qso]
getQsoList = do
l <- _logQsos <$> gets _stateLog
return $ Data.Foldable.foldr (:) [] l
getQsoSeq :: HamLog (Seq Qso)
getQsoSeq = _logQsos <$> gets _stateLog
filterCallsign :: Text
-> HamLog (Seq Qso)
filterCallsign callsign = do
l <- getQsoSeq
let f q = let cs = T.toUpper $ _qsoCallsign q
cs' = T.strip $ T.toUpper callsign
in cs == cs'
return (S.filter f l)
isDuplicate :: Text
-> HamLog Bool
isDuplicate callsign = do
s <- filterCallsign callsign
case s of
Empty -> return False
_ -> return True
findQsos :: Text
-> Maybe Band
-> Maybe QsoMode
-> HamLog (Seq Qso)
findQsos callsign mband mmode = do
s <- filterCallsign callsign
let msb = maybe Nothing (\a -> Just $ S.filter (\qso -> band (_qsoFrequency qso) == a) s) mband
Just s2 = msb <|> Just s
msm = maybe Nothing (\a -> Just $ S.filter (\qso -> _qsoMode qso == a) s2) mmode
Just s3 = msm <|> Just s2
return s3
data Duplicate = Duplicate { duplicateBand :: Bool
, duplicateMode :: Bool
, duplicateQso :: Qso
}
instance Show Duplicate where
show d = "Met " ++ c ++ " on " ++ show b ++ " using " ++ show m ++ " at " ++ show (_qsoTimeStart q)
where b = band $ _qsoFrequency q
m = _qsoMode q
q = duplicateQso d
c = T.unpack $ _qsoCallsign q
findDuplicateQsos :: Qso
-> HamLog (Seq Duplicate)
findDuplicateQsos qso = do
let qso' = sanitizeQso qso
b = band $ _qsoFrequency qso'
c = _qsoCallsign qso'
m = _qsoMode qso'
f a = if _qsoCallsign a == c && (a /= qso')
then Just (Duplicate { duplicateBand = band (_qsoFrequency a) == b,
duplicateMode = _qsoMode a == m,
duplicateQso = a })
else Nothing
catM :: S.Seq (Maybe a) -> S.Seq a
catM s = fmap fromJust $ S.filter isJust s
qsos <- getQsoSeq
return $ catM $ fmap f qsos
lookupFcc :: Text -> HamLog (Maybe FccResult)
lookupFcc a = liftIO $ fccLookup' a
lookupFccName :: Text -> HamLog Text
lookupFccName a = liftIO $ fccLookupName a
makeCabrillo :: Cabrillo -> HamLog CabrilloLog
makeCabrillo cab = do
l <- getQsoList
myCall <- _qsoDefaultCallsign <$> asks _configQsoDefaults
let l' = Prelude.concatMap toCabrillo l
return $ CabrilloLog cab l'
cat :: CAT.CAT IO a -> HamLog (Either CAT.CATError (a, [Text]))
cat act = do
usecat <- gets _stateUseCat
if usecat
then do
radio_interface <- fromJust <$> gets _stateSerialCAT
conf <- asks _configCat
let catstate = CAT.defaultState { CAT.stateInterface = radio_interface }
result <- liftIO $ CAT.runCAT conf catstate act
case result of
Left (CAT.CATError t s) -> do
tell $ ["CAT failed: " <> s <> " - turning off CAT for now."]
s <- get
put $ s { _stateUseCat = False }
Right a -> tell $ snd a
return result
else return $ Left $ (CAT.CATError CAT.CATErrorGeneric "CAT is turned off.")