quarantimer-1.20200326: 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.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Network.Wai.Parse
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 as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Codec.Binary.Base64 as B64
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]
	:<|> "sessionid" :> Get '[JSON] SessionID
	:<|> "static" :> Raw
	:<|> ".well-known" :> Raw

newtype UserID = UserID UUID
	deriving (Eq, Show)

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

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

newtype SessionID = SessionID UUID
	deriving (Eq, Show, ToJSON, Generic)

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
	, surfaceDeprecated :: Bool
	}
	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 SessionID [Thing]

instance ToHtml UserPage where
	toHtml (UserPage _ (SessionID sid) 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_ $
				"var sessionid = \"" <> T.pack (toString sid) <> "\";"
			script_ $
				"var imagesize = " <> T.pack (show maxImageSize) <> ";"
			script_ [src_ "/static/js.js"] ("" :: T.Text)
		body_ $ do
			let photograbber = div_ [class_ "camera"] $ do
				video_ [id_ "video"] "Video stream not available."
				canvas_ [id_ "canvas"] mempty
				img_ [id_ "photo"]

			let f = form_ 
				[ method_ "post"
				, action_ "post"
				, enctype_ "multipart/form-data"
				, onsubmit_ "validateform();"
				] $ do
				input_
					[ type_ "hidden"
					, name_ "photo"
					, id_ "formphoto"
					]
				input_
					[ type_ "button"
					, id_ "capturebutton"
					, value_ "Take photo"
					]
				forM_ surfaces $ \surface -> 
					unless (surfaceDeprecated surface) $ do
						br_ []
						let (SurfaceID s) = surfaceID surface
						input_
							[ type_ "checkbox"
							, class_ "surface"
							, id_ (surfaceDesc surface)
							, name_ (surfaceDesc surface)
							, value_ (T.pack (show s))
							]
						label_ [ for_ (surfaceDesc surface)]
							(toHtml ((surfaceDesc surface)))
				br_ []
				input_
					[ type_ "submit"
					, id_ "uploadbutton"
					, value_ "Add"
					]

			header_ $ do
				h1_ $ do
					a_ [href_ "/"] "Quarantimer"
					": Coronavirus quarantine timer"
				p_ $ do
					"When you have something that may "
					"be contaminated, take its picture, "
					"select the surfaces it has, "
					"and this page will tell you when "
					"it's safe to touch it."

				photograbber

				div_ 
					[ id_ "uploadmsg"
					, style_ "display: none;"
					]
					"Uploading, please wait.."
				div_
					[ id_ "uploadover"
					, style_ "display: none;"
					]
					mempty

				f

			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
					"Based on 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) and "
					a_ [href_ "https://doi.org/10.1101/2020.03.15.20036673"]
						"Stability of SARS-CoV-2 in different environmental conditions"
					" (March 18, 2020). Timers will update as improved research becomes available."
				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
	sid <- SessionID <$> nextRandom
	let app = serveWithContext httpAPI ctx (server q sid)
	forM_ [1..numImageCores] $ \_ ->
		async $ queueRunnerThread q
	void $
		waitthread "https" (runTLS tlssettings (setPort 443 settings) app)
			`concurrently`
		waitthread "http" (runSettings (setPort 80 settings) app)
			`concurrently`
		waitthread "http 8080" (runSettings (setPort devPort settings) app)
  where
	settings = defaultSettings
	tlssettings = tlsSettingsChain 
		(le </> "cert.pem")
		[le </> "chain.pem"]
		(le </> "privkey.pem")
	le = "/etc/letsencrypt/live" </> hostname

	ctx = multipartOpts :. EmptyContext
	multipartOpts = (defaultMultipartOptions (Proxy :: Proxy Tmp))
		-- the photo is sent base64 encoded, so bump
		-- this limit
		{ generalOptions = setMaxRequestParmsSize 6533600
			defaultParseRequestBodyOptions
		}

	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)

httpAPI :: Proxy HttpAPI
httpAPI = Proxy

server :: ImageQueue -> SessionID -> Server HttpAPI
server q sid = topPage
	:<|> userPage sid
	:<|> thingList
	:<|> addThing q
	:<|> addThing' q
	:<|> surfaceList
	:<|> sessionId sid
	:<|> 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 :: SessionID -> UserID -> Handler UserPage
userPage sid u = UserPage u sid <$> thingList u

sessionId :: SessionID -> Handler SessionID
sessionId sid = do
	liftIO $ logMessage "sessionid requested"
	return sid

surfaceList :: Handler [Surface]
surfaceList = pure surfaces

-- Per https://www.nejm.org/doi/10.1056/NEJMc2004973
surfaces :: [Surface]
surfaces =
	-- https://www.nejm.org/doi/10.1056/NEJMc2004973
	[ Surface (SurfaceID 1) "cardboard" 
		(staticFileUrl "cardboard.jpg")
		(hours 24) False
	-- https://doi.org/10.1101/2020.03.15.20036673
	-- tissue and printing paper
	, Surface (SurfaceID 4) "paper"
		(staticFileUrl "paper.jpg")
		(hours 3) False
	-- https://doi.org/10.1101/2020.03.15.20036673
	, Surface (SurfaceID 5) "cloth"
		(staticFileUrl "cloth.jpg")
		(days 2) False
	, Surface (SurfaceID 2) "plastic"
		(staticFileUrl "plastic.jpg")
		(hours 72) False
	-- https://doi.org/10.1101/2020.03.15.20036673
	-- 7 days for stainless steel
	--
	-- https://www.nejm.org/doi/10.1056/NEJMc2004973
	-- had a lower number of 72 hours for stainless.
	--
	-- Last much less time on copper, but don't expect people to
	-- know what is copper and what looks like copper but is
	-- not..
	, Surface (SurfaceID 3) "metal"
		(staticFileUrl "metal.jpg")
		(days 7) False
	-- https://doi.org/10.1101/2020.03.15.20036673
	-- found virus after 7 days in outer layer of surgical mask.
	-- Unknown how long it lasts, and they should be discarded or
	-- sterilized, so use 1 year as the timeout.
	, Surface (SurfaceID 6) "surgical mask"
		(staticFileUrl "mask.jpg")
		(days 365) False
	, Surface (SurfaceID 0) "other"
		(staticFileUrl "other.jpg")
		(hours 72) 
		True -- do not offer as a selection any more
	]
  where
	hours n = 60*60*n
	days n = 24 * hours 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, p) -> 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)
		let tmp = destfile <.> "tmp"
		liftIO $ B.writeFile tmp p
		ok <- liftIO $ queueAction q $
			scaleImage maxImageSize tmp destfile
		liftIO $ removeFile tmp
		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
		-- The photo is sent base64 encoded, so decode it.
		photodata <- lookupInput "photo" d
		let b = T.encodeUtf8 $ T.drop 1 $ snd $ T.break (== ',') photodata
		p <- case B64.decode b of
			Left _ -> Nothing
			Right v -> Just v
		return (s, p)

-- Most recently added first.
thingList :: UserID -> Handler [Thing]
thingList user@(UserID u) = liftIO $ do
	exists <- doesDirectoryExist userdir
	l <- if exists
		then reverse . sortOn thingQuarantineStarted . catMaybes 
			<$> (mapM go =<< getDirectoryContents userdir)
		else return []
	logMessage $ "got a user's list of " ++ show (length l) ++ " things"
	return l
  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 = 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)