scheduling-0.1.0.0: app/Main.hs

module Main where

import qualified Data.Map as Map
import Data.Map (Map)
import Data.Text (Text)
import Options.Generic (Generic, ParseRecord, Unwrapped, Wrapped, unwrapRecord, (:::), type (<?>)(..))
import Data.Text (Text)
import System.IO (stdout)
import Data.Maybe (fromMaybe, catMaybes, fromJust)
import Text.Printf (printf)
import Control.Monad
import Control.Scheduling
import Data.Time
import Data.Time.Format
import Control.Lens hiding (Wrapped, Unwrapped)
import qualified Data.ByteString.Lazy as BS
import Debug.Trace (traceShowId)
--import Control.Monad.Log
import qualified Network.Google.Sheets as S
import Network.Google.Resource.Sheets.Spreadsheets.Get
import Network.Google.Sheets hiding (Text, sheet)

sheetName :: Sheet -> Maybe Text
sheetName s = join $ s ^. sProperties <&> view sTitle

events = [ ("Welcome", ("Mon 08:00", "Mon 09:00"))
         , ("Shared lunch", ("Wed 12:00", "Wed 13:00"))
         ]

data Args w = Init { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"
                   , force :: w ::: Bool <?> "If set, existing tables will be overwritten"
                   , windows :: w ::: [String] <?> "Time windows (can specify multiple times): format is 'YYYY-MM-DD HH:MM-HH:MM'"
                   --, granularity :: w ::: Maybe Integer <?> "Time granularity, in minutes, for scheduling"
                   }
            | Show { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"
                   }
            | Solve { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"
                    , force :: w ::: Bool <?> "If set, existing tables will be overwritten"
                    }
            | Emails { access :: w ::: Maybe Text <?> "Access code for Google Sheets endpoint"
                     , jhuFacultyEmails :: w ::: String <?> "Path to write JHU faculty emails"
                     , nonJhuFacultyEmails :: w ::: String <?> "Path to write non-JHU-faculty emails"
                     --, nonFacultyEmails :: w ::: String <?> "Path to write non-faculty emails"
                     , prospectEmails :: w ::: String <?> "Path to write prospect emails"
                     }
  deriving (Generic)                             
                                                            
instance ParseRecord (Args Wrapped)
deriving instance Show (Args Unwrapped)

-- add resources!

generateSlots gran wins = do
  let dates = ["2022-01-" ++ (show d) | d <- [17..21]]
  toDrop <- sequence $ [] -- stringsToSlots "2021-03-08" "2021-03-08" "17:00" "17:00" gran
                       --, stringsToSlots "2021-03-10" "2021-03-10" "17:00" "19:00" gran
                       --, stringsToSlots "2021-03-12" "2021-03-12" "17:00" "19:00" gran
                       --]
  slots <- sequence $ [stringsToSlots d d "08:00" "22:00" gran | d <- dates]
  let toDrop' = concat toDrop
      slots' = [s | s <- concat slots, not $ s `elem` toDrop']
  return slots'

getCurrentCount :: State -> Map (Text, Text) Int
getCurrentCount state = Map.fromListWith (+) (pro ++ base)
  where
    fac = (Map.toList . fromMaybe Map.empty) $ state^.individualMeetings
    base = map (\p -> ((p^.firstName, p^.lastName), 0)) (state ^. prospects)
    mts = concat $ map (Map.toList . snd) fac
    pro = map ((,1) . fst) mts

getCurrentCount' :: State -> [((Text, Text), [(Text, Text)])]
getCurrentCount' state = fac --Map.fromListWith (+) (pro ++ base)
  where
    fac = (map (\(k, v) -> (k, Map.keys v)) . Map.toList . fromMaybe Map.empty) $ state^.individualMeetings
    --base = map (\p -> ((p^.firstName, p^.lastName), Map.size $ p^.)) (state ^. faculty)
    --mts = concat $ map (Map.toList . snd) fac
    --pro = map ((,1) . fst) mts


main :: IO ()
main = do
  ps <- unwrapRecord "" :: IO (Args Unwrapped)
  let sid = fromMaybe "NULL" (access ps)
  ssheet <- readSpreadsheet sid
  let state = readState (generateSlots 60 []) ssheet
  case ps of Init{..} -> do
               let slu = ssheet^.sheetLookup
                   state' = state { _slots=generateSlots 60 [] }
               if ((slu Map.!? "Interviewer Preferences") == Nothing && (slu Map.!? "Interviewer Availability") == Nothing) || force == True
                 then writeForms sid (slu Map.!? "Interviewer Availability") (slu Map.!? "Interviewer Preferences") (slu Map.!? "Prospect Availability") state'                
                 else putStrLn "Refusing to overwrite existing forms (you may specify '--force' if you're sure)"
             Show{..} -> do
               --let mtg = (Map.toList . Map.map (\x -> length $ Map.keys x) . fromJust) $ state^.individualMeetings
               --putStrLn $ (show . sum . map snd) mtg
               --putStrLn $ unlines (map show mtg)
               putStrLn $ show $ (state^.individualMeetings)
               putStrLn $ unlines $ map show (getCurrentCount' state)
               --print $ getCurrentCount state
               return ()
               --putStrLn $ show $ (head $ state^.faculty) ^.availability
               --putStrLn $ show $ state^.faculty
               --putStrLn $ show $ state^.requestedMeetings
               --putStrLn $ show $ state^.individualMeetings
               --printSchedules (compressSlots state)
             Solve{..} -> do
               let slu = ssheet^.sheetLookup
                   state' = state { _slots=generateSlots 60 [] }
               --let state' = compressSlots $ state { _slots= Just $ [s | s <- (fromMaybe [] (defaultSlots 60))]}
               state'' <- solveSchedule state'
               if ((slu Map.!? "Interviewer Schedule") == Nothing && (slu Map.!? "Prospect Schedule" == Nothing)) || force == True
                 then writeSchedule sid (slu Map.!? "Interviewer Schedule") (slu Map.!? "Prospect Schedule") state'' (fromJust $ generateSlots 60 [])
                 else putStrLn "Refusing to overwrite existing schedule (you may specify '--force' if you're sure)"

               --print $ getCurrentCount state''
               --print $ map (\(x, y) -> (x, length y)) (getCurrentCount' state'')
               --putStrLn $ unlines $ map (show . 
               return ()
             Emails{..} -> do
               emails <- generateEmails prospectEmails jhuFacultyEmails nonJhuFacultyEmails state
               sequence $ map (\(f, m) -> BS.writeFile f m) emails
               return ()