souplesse

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

Point.hs (4342B)

      1 {-# LANGUAGE DataKinds #-}
      2 {-# LANGUAGE DerivingStrategies #-}
      3 {-# LANGUAGE EmptyDataDecls #-}
      4 {-# LANGUAGE FlexibleContexts #-}
      5 {-# LANGUAGE FlexibleInstances #-}
      6 {-# LANGUAGE GADTs #-}
      7 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
      8 {-# LANGUAGE MultiParamTypeClasses #-}
      9 {-# LANGUAGE OverloadedStrings #-}
     10 {-# LANGUAGE QuasiQuotes #-}
     11 {-# LANGUAGE RecordWildCards #-}
     12 {-# LANGUAGE StandaloneDeriving #-}
     13 {-# LANGUAGE TemplateHaskell #-}
     14 {-# LANGUAGE TypeFamilies #-}
     15 {-# LANGUAGE UndecidableInstances #-}
     16 
     17 module Point
     18   ( Pos (..),
     19     Point (..),
     20     save,
     21     fetch,
     22     migration,
     23   )
     24 where
     25 
     26 import Control.Exception
     27 import Control.Monad.IO.Class (MonadIO, liftIO)
     28 import Control.Monad.Trans.Reader (ReaderT)
     29 import Data.Aeson
     30 import Data.ByteString.Lazy.Char8 qualified as L
     31 import Data.Either
     32 import Data.Functor ((<&>))
     33 import Data.List as List
     34 import Data.List qualified
     35 import Data.Map as Map
     36 import Data.Maybe (isJust)
     37 import Data.Text qualified
     38 import Data.Text.Lazy as T
     39 import Data.Time
     40 import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, addUTCTime)
     41 import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
     42 import Data.Time.ISO8601 qualified
     43 import Database.Persist
     44 import Database.Persist.Class
     45 import Database.Persist.Postgresql
     46   ( ConnectionString,
     47     SqlBackend,
     48     createPostgresqlPool,
     49     pgConnStr,
     50     pgPoolSize,
     51     rawExecute,
     52     runMigration,
     53     runSqlPool,
     54   )
     55 import Database.Persist.TH
     56 import Debug.Trace (trace, traceShow)
     57 import Session qualified
     58 import Text.Read (readMaybe)
     59 import Text.XML
     60 import Text.XML.Cursor as Cursor
     61 
     62 -- import Track (Point (..), Pos (..))
     63 -- import Track as T
     64 
     65 data Pos = Pos Double Double (Maybe Double) deriving (Show, Eq)
     66 
     67 type Power = Maybe Int
     68 
     69 type Cadence = Maybe Int
     70 
     71 type HeartRate = Maybe Int
     72 
     73 data Point = Point
     74   { pos :: Pos,
     75     time :: UTCTime,
     76     cadence :: Cadence,
     77     power :: Power,
     78     heartRate :: HeartRate
     79   }
     80   deriving (Show)
     81 
     82 instance ToJSON Pos where
     83   toJSON (Pos lat lon ele) =
     84     case ele of
     85       Just e -> object ["lat" .= lat, "lon" .= lon, "ele" .= e]
     86       Nothing -> object ["lat" .= lat, "lon" .= lon, "ele" .= Null]
     87 
     88 instance ToJSON Point where
     89   toJSON Point {..} =
     90     object
     91       [ "pos" .= pos,
     92         "time" .= utcTimeToPOSIXSeconds time,
     93         "cadence" .= cadence,
     94         "power" .= power,
     95         "heartRate" .= heartRate
     96       ]
     97 
     98 share
     99   [mkPersist sqlSettings, mkMigrate "migration"]
    100   [persistLowerCase|
    101 Trkpt
    102     lat Double
    103     lon Double
    104     ele Double Maybe
    105     time UTCTime
    106     cadence Int Maybe
    107     power Int Maybe
    108     heartRate  Int Maybe
    109 |]
    110 
    111 fromPoint :: Point -> Trkpt
    112 fromPoint p =
    113   let Pos lat lon ele = pos p
    114    in Trkpt lat lon ele (time p) (cadence p) (power p) (heartRate p)
    115 
    116 toPoint :: Entity Trkpt -> Point
    117 toPoint entity =
    118   let tkp = (\(Entity _ tkp) -> tkp) entity
    119       pos = Pos (trkptLat tkp) (trkptLon tkp) (trkptEle tkp)
    120    in Point
    121         pos
    122         (trkptTime tkp)
    123         (trkptCadence tkp)
    124         (trkptPower tkp)
    125         (trkptHeartRate tkp)
    126 
    127 data OverlapExists = OverlapExists String deriving (Show)
    128 
    129 instance Exception OverlapExists
    130 
    131 fetch :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m [Point]
    132 fetch start duration = do
    133   let finish = addUTCTime duration start
    134   trkpts <- selectList [TrkptTime >. start, TrkptTime <. finish] []
    135   return $ List.map toPoint trkpts
    136 
    137 -- any :: (MonadIO m) => UTCTime -> NominalDiffTime -> ReaderT SqlBackend m Bool
    138 any start duration = do
    139   let finish = addUTCTime duration start
    140   exists <- selectFirst [TrkptTime >. start, TrkptTime <. finish] []
    141   return $ isJust exists
    142 
    143 startTime :: [Point] -> UTCTime
    144 startTime (p : ps) = List.foldr (\a b -> min b (time a)) (time p) ps
    145 
    146 duration :: [Point] -> NominalDiffTime
    147 duration track =
    148   case track of
    149     [] -> 0
    150     (p : ps) ->
    151       let start = startTime track
    152           finish = List.foldr (\a b -> max b (time a)) (time p) ps
    153        in diffUTCTime finish start
    154 
    155 save :: (MonadIO m) => [Point] -> ReaderT SqlBackend m (Either OverlapExists [Point])
    156 save track = do
    157   let start = startTime track
    158   priors <- Point.any start (duration track)
    159   if priors
    160     then return $ Left (OverlapExists "track overlaps with existing data")
    161     else do
    162       mapM_ (Database.Persist.Class.insert . fromPoint) track
    163       Session.refreshDrafts
    164       return $ Right track