quarantimer-1.20200323: quarantimer.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveAnyClass #-}

module Main where

import Config
import Image

import Servant
import Servant.HTML.Lucid
import Servant.Multipart
import Lucid
import Lucid.Base (makeAttribute)
import Network.Wai (Application)
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Data.UUID
import Data.UUID.V4
import Data.Aeson
import GHC.Generics
import Control.Monad.IO.Class
import Data.Maybe
import Data.List
import Data.Time.Clock
import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as T
import Text.Read
import System.FilePath
import Control.Monad
import Control.Concurrent.Async
import System.Directory
import System.IO

type HttpAPI = Get '[HTML] TopPage
	:<|> Capture "uuid" UserID :> Get '[HTML] UserPage
	:<|> Capture "uuid" UserID :> "things" :> Get '[JSON] [Thing]
	:<|> Capture "uuid" UserID :> "add"
		:> MultipartForm Tmp (MultipartData Tmp)
		:> Post '[JSON] Thing
	:<|> Capture "uuid" UserID :> "post"
		:> MultipartForm Tmp (MultipartData Tmp)
		:> Post '[HTML] UserPage
	:<|> "surfaces" :> Get '[JSON] [Surface]
	:<|> "static" :> Raw
	:<|> ".well-known" :> Raw

newtype UserID = UserID UUID
	deriving (Eq, Show)

newtype SurfaceID = SurfaceID Int
	deriving (Eq, Show, ToJSON, Generic)

instance FromHttpApiData UserID where
	parseUrlPiece t = UserID <$> parseUrlPiece t

data Thing = Thing
	{ thingSurface :: Surface
	, thingPhoto :: UrlString
	, thingQuarantineStarted :: UTCTime
	, thingSecondsUntilSafe :: Integer
	}
	deriving (ToJSON, Generic)

data Surface = Surface
	{ surfaceID :: SurfaceID
	, surfaceDesc :: T.Text
	, surfaceIcon :: UrlString
	, surfaceSecondsUntilSafe :: Integer
	}
	deriving (ToJSON, Generic)

type UrlString = String

data TopPage = TopPage

instance ToHtml TopPage where
	toHtml _ = html_ $ do
		head_ $ do
			title_ "hello"
		body_ $ do
			p_ "hello"
	toHtmlRaw = toHtml

data UserPage = UserPage UserID [Thing]

instance ToHtml UserPage where
	toHtml (UserPage _ things) = html_ $ do
		meta_
			[ name_ "viewport"
			, content_ "width=device-width, initial-scale=1"
			]
		head_ $ do
			title_ "Quarantimer"
			link_ 
				[ href_ "/static/style.css"
				, rel_ "stylesheet"
				, type_ "text/css"
				]
			script_ [src_ "/static/js.js"] ("" :: T.Text)
		body_ $ do
			header_ $ do
				h1_ $ do
					a_ [href_ "/"] "Quarantimer"
					": Coronavirus quarantine timer"
				p_ $ do
					"When you have something that may "
					"be contaminated, take its picture, "
					"and this page will tell you when "
					"it's safe to touch it."

			form_ 
				[ method_ "post"
				, action_ "post"
				, enctype_ "multipart/form-data"
				, onsubmit_ "validateform();"
				] $ do
				input_ 
					[ type_ "file"
					, name_ "photo"
					, camera
					]
				forM_ surfaces $ \surface -> do
					br_ []
					let (SurfaceID sid) = surfaceID surface
					input_
						[ type_ "checkbox"
						, class_ "surface"
						, id_ (surfaceDesc surface)
						, name_ (surfaceDesc surface)
						, value_ (T.pack (show sid))
						]
					label_ [ for_ (surfaceDesc surface)]
						(toHtml ((surfaceDesc surface)))
				br_ []
				input_ [type_ "submit", value_ "Add"]

			forM_ things $ \thing -> div_ [class_ "thing"] $ do
				img_ 
					[ class_ "photo"
					, src_ (T.pack (thingPhoto thing))
					]
				let timer = T.pack $ show $
					thingSecondsUntilSafe thing
				span_ 
					[ class_ "timer"
					, title_ timer
					] (toHtml timer)
				br_ []
				br_ []

			footer_ $ do
				p_ $ do
					"Covid-19 data from "
					a_ [href_ "https://www.nejm.org/doi/10.1056/NEJMc2004973"]
						"Aerosol and Surface Stability of SARS-CoV-2 as Compared with SARS-CoV-1"
					" (March 17, 2020)"
				p_ $ do
					"Quarantimer "
					a_ [href_ "https://git.joeyh.name/index.cgi/quarantimer.git/"]
						"source code"
					" by "
					a_ [href_ "https://joeyh.name/"]
						"Joey Hess"
					". Have an idea to improve it? "
					a_ [href_ "mailto:joeyh@joeyh.name"]
						"Email me"
				p_ $ do
					"This is free software, and this "
					"service is provided for free. "
					"There is no warranty."
				p_ $ do
					"Your information will be shared "
					"only with people who you give "
					"a link to this page."
				p_ $ "Be safe. Wash your hands!"
				
	toHtmlRaw = toHtml

camera :: Attribute
camera = makeAttribute "capture" "environment"

main :: IO ()
main = do
	hSetBuffering stdout LineBuffering
	hSetBuffering stderr LineBuffering
	createDirectoryIfMissing False staticDir
	q <- mkImageQueue
	forM_ [1..numImageCores] $ \_ ->
		async $ queueRunnerThread q
	void $
		waitthread "https" (runTLS tlssettings (setPort 443 settings) (app q))
			`concurrently`
		waitthread "http" (runSettings (setPort 80 settings) (app q))
			`concurrently`
		waitthread "http 8080" (runSettings (setPort 7070 settings) (app q))
  where
	settings = defaultSettings
	tlssettings = tlsSettingsChain 
		(le </> "cert.pem")
		[le </> "chain.pem"]
		(le </> "privkey.pem")
	le = "/etc/letsencrypt/live" </> hostname

	waitthread d a = do
		t <- async a
		res <- waitCatch t
		case res of
			Left e -> logMessage $ d ++ " server failed: " ++ show e
			Right () -> return ()

staticFileUrl :: FilePath -> UrlString
staticFileUrl f = "/static/" ++ f

staticUserFileUrl :: UserID -> FilePath -> UrlString
staticUserFileUrl (UserID u) f = staticFileUrl (toString u </> f)

app :: ImageQueue -> Application
app q = serve httpAPI (server q)

httpAPI :: Proxy HttpAPI
httpAPI = Proxy

server :: ImageQueue -> Server HttpAPI
server q = topPage
	:<|> userPage
	:<|> thingList
	:<|> addThing q
	:<|> addThing' q
	:<|> surfaceList
	:<|> serveDirectoryWebApp staticDir
	:<|> serveDirectoryWebApp (staticDir </> ".well-known")

topPage :: Handler TopPage
topPage = do
	u <- UserID <$> liftIO nextRandom
	redirUserPage u

redirUserPage :: UserID -> Handler a
redirUserPage (UserID u) = do
	let redirto = B8.pack ("/" ++ show u ++ "/")
	throwError $ err303 { errHeaders = [("Location", redirto)] }

userPage :: UserID -> Handler UserPage
userPage u = UserPage u <$> thingList u

surfaceList :: Handler [Surface]
surfaceList = return surfaces

-- Per https://www.nejm.org/doi/10.1056/NEJMc2004973
surfaces :: [Surface]
surfaces =
	[ Surface (SurfaceID 1) "cardboard" 
		(staticFileUrl "cardboard.jpg")
		(hours 24)
	, Surface (SurfaceID 2) "plastic"
		(staticFileUrl "plastic.jpg")
		(hours 72)
	, Surface (SurfaceID 3) "metal"
		(staticFileUrl "metal.jpg")
		(hours 72)
	-- copper much less time, but don't expect people to
	-- know what is copper and what looks like copper but is
	-- not..
	, Surface (SurfaceID 0) "other"
		(staticFileUrl "other.jpg")
		(hours 72)
	]
  where
	hours n = 60*60*n

addThing' :: ImageQueue -> UserID -> MultipartData Tmp -> Handler UserPage
addThing' q u d = do
	_ <- addThing q u d
	redirUserPage u

addThing :: ImageQueue -> UserID -> MultipartData Tmp -> Handler Thing
addThing q user@(UserID u) d = case parseform of
	Nothing -> throwError err400
	Just (s, f) -> do
		fid <- liftIO nextRandom
		-- The filename contains the SurfaceID, and the UserID.
		-- The creation time of the file indicates when to start
		-- from, and that and the picture in the file is all the
		-- data we need to store.
		let newfile = toString u </> toString fid
			<.> (\(SurfaceID n) -> show n) (surfaceID s)
			<.> "jpg"
		let destfile = staticDir </> newfile

		liftIO $ createDirectoryIfMissing False (takeDirectory destfile)
		ok <- liftIO $ queueAction q $
			scaleImage maxImageSize f destfile
		liftIO $ logMessage $ "image converted and saved: "
			++ show ok ++ " " ++ T.unpack (surfaceDesc s)
		now <- liftIO getCurrentTime
		if ok
			then return $ Thing
				{ thingSurface = s
				, thingPhoto = staticUserFileUrl user newfile
				, thingQuarantineStarted = now
				, thingSecondsUntilSafe = surfaceSecondsUntilSafe s
				}
			else throwError err500
  where
	parseform = do
		let sids = map SurfaceID $
			mapMaybe (readMaybe . T.unpack . iValue) (inputs d)
		-- When multiple surfaces were selected, use the one
		-- with the longest time until safe.
		s <- listToMaybe $ reverse $ sortOn surfaceSecondsUntilSafe $
			filter (\x -> surfaceID x `elem` sids) surfaces
		f <- fdPayload <$> lookupFile "photo" d
		return (s, f)

-- Most recently added first.
thingList :: UserID -> Handler [Thing]
thingList user@(UserID u) = liftIO $ do
	logMessage "got a user's thing list"
	exists <- doesDirectoryExist userdir
	if exists
		then reverse . sortOn thingQuarantineStarted . catMaybes 
			<$> (mapM go =<< getDirectoryContents userdir)
		else return []
  where
	go f = case parsefnsurface f of
		Nothing -> return Nothing
		Just s -> do
			mtime <- getModificationTime (userdir </> f)
			now <- getCurrentTime
			let secsold = max 0 (floor (diffUTCTime now mtime))
			let ts = max 0 (surfaceSecondsUntilSafe s - secsold)
			return $ Just $ Thing
				{ thingSurface = s
				, thingPhoto = staticUserFileUrl user f
				, thingQuarantineStarted = mtime
				, thingSecondsUntilSafe = ts
				}
				
	userdir = staticDir </> toString u

	parsefnsurface f
		| takeExtension f == ".jpg" = do
			let f' = dropExtension f
			sid <- SurfaceID 
				<$> readMaybe (drop 1 (takeExtension f'))
			listToMaybe $
				filter (\x -> surfaceID x == sid) surfaces
		| otherwise = Nothing

logMessage :: String -> IO ()
logMessage s = do
	now <- getCurrentTime
	putStrLn ("[" ++ show now ++ "] " ++ s)