quarantimer (empty) → 1.20200323

raw patch · 11 files changed

+635/−0 lines, 11 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, bytestring, directory, filepath, lucid, process, servant, servant-client, servant-lucid, servant-multipart, servant-server, stm, text, time, uuid, wai, warp, warp-tls

Files

• CHANGELOG +5/−0
• Config.hs +13/−0
• Image.hs +35/−0
• LICENSE +25/−0
• README +11/−0
• Setup.hs +2/−0
• TODO +10/−0
• quarantimer.cabal +54/−0
• quarantimer.hs +357/−0
• static/js.js +67/−0
• static/style.css +56/−0

@@ -0,0 +1,5 @@+quarantimer (1.20200323) unstable; urgency=medium++  * First release.++ -- Joey Hess <id@joeyh.name>  Mon, 23 Mar 2020 19:28:04 -0400

@@ -0,0 +1,13 @@+module Config where++hostname :: String+hostname = "quarantimer.app"++staticDir :: FilePath+staticDir = "static"++maxImageSize :: Int+maxImageSize = 640++numImageCores :: Int+numImageCores = 1

@@ -0,0 +1,35 @@+module Image where++import System.Process+import System.Exit+import Control.Concurrent.STM++newtype ImageQueue = ImageQueue (TQueue (IO Bool, TMVar Bool))++mkImageQueue :: IO ImageQueue+mkImageQueue = ImageQueue <$> newTQueueIO++queueAction :: ImageQueue -> IO Bool -> IO Bool+queueAction (ImageQueue q) a = do+	v <- newEmptyTMVarIO+	atomically $ writeTQueue q (a, v)+	atomically $ takeTMVar v++queueRunnerThread :: ImageQueue -> IO ()+queueRunnerThread q@(ImageQueue qv) = do+	(a, v) <- atomically $ readTQueue qv+	r <- a+	_ <- atomically $ tryPutTMVar v r+	queueRunnerThread q++scaleImage :: Int -> FilePath -> FilePath -> IO Bool+scaleImage maxsz src dst = do+	p <- spawnProcess "convert"+		[ src+		, "-resize"+		-- The ">" makes it only shrink large images, not scale up+		-- small.+		, show maxsz ++ "x" ++ show maxsz ++ ">"+		, dst+		]+	(== ExitSuccess) <$> waitForProcess p

@@ -0,0 +1,25 @@+BSD 2-Clause License++Copyright (c) 2020, Joey Hess+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,11 @@+The server is written in Haskell, build it with cabal or stack.+You should edit Config.hs first.++Imagemagick needs to be installed, it is used to process images.++The first run, the server will fail to listen on https due to a missing+certificate, but it will listen on http, so you can use certbot to get a+letsencrypt certificate, and then restart the server.++Contact Joey Hess <joeyh@joey.name> by email with any bug reports,+questions, or patches.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,10 @@+* Use webrtc to capture photo, less clunky and allows scaling client-side+  for faster upload.+* Once quarantine expires, show how long it's been since expiry in case the+  user is feeling extra careful.+* Expire old images after some reasonable amount of time. This can be done+  with just a find command.+* Add systemd service file and Makefile to install it better.+* Improve CSS. (Patches welcome on this one.)+* The javascript could let things be added in offline mode, and sync up+  with the server next time it comes online. (Patches welcome on this one.)

@@ -0,0 +1,54 @@+Name: quarantimer+Version: 1.20200323+Cabal-Version: >= 1.8+Maintainer: Joey Hess <id@joeyh.name>+Author: Joey Hess+Stability: Experimental+Copyright: 2020 Joey Hess+License: BSD2+License-File: LICENSE+Homepage: https://quarantimer.app/+Category: Health+Build-Type: Simple+Synopsis: Coronavirus quarantine timer web app for your things+Description:+  Web app that tracks how long things potentially contaminated with+  Covid-19 have been in quarantine.+Extra-Source-Files:+  README+  TODO+  CHANGELOG+  static/js.js+  static/style.css++Executable quarantimer+  Main-Is: quarantimer.hs+  GHC-Options: -threaded -Wall -fno-warn-tabs -O2+  Build-Depends:+      base (>= 4.11 && < 5.0)+    , servant (>= 0.15 && < 0.18)+    , servant-server (>= 0.15 && < 0.18)+    , servant-client (>= 0.15 && < 0.18)+    , servant-lucid (== 0.9.0.1)+    , servant-multipart (== 0.11.*)+    , lucid (== 2.9.12)+    , aeson (>= 1.4.2 && < 1.5)+    , wai (== 3.2.*)+    , warp (== 3.2.*)+    , warp-tls (== 3.2.*)+    , uuid (== 1.3.*)+    , bytestring+    , text+    , filepath+    , time+    , async+    , directory+    , process+    , stm+  Other-Modules:+    Config+    Image++source-repository head+  type: git+  location: git://git.joeyh.name/quarantimer.git

@@ -0,0 +1,357 @@+{-# 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)

@@ -0,0 +1,67 @@+var things;++window.onload=function(){+	var loaddate = Date.now();+	things = document.getElementsByClassName('thing');+	for (var i = 0; i < things.length; i++) {+		var elt = things[i];+		var img = elt.getElementsByTagName("img")[0];+		things[i].img = img;+		var timer = elt.getElementsByClassName("timer")[0];+		things[i].timer = timer;+		var n = parseInt(timer.attributes.title.value);+		var d = loaddate + (n * 1000);+		things[i].enddate = d;+	}++	animate();+}++function displayUnit(v,u) {+	var s;+	if (v == 1) { s = "" } else { s = "s" }+	return (v + " " + u + s);+}++function animate() {+	now = Date.now();+	for (var i = 0; i < things.length; i++) {+		var img = things[i].img;+		var timer = things[i].timer;+		var diff = (things[i].enddate - now) / 1e3;+		var h=(diff/60/60)>>0;+		var m=(diff/60 - h*60)>>0;+		if (diff > 0) {+			img.className = "infected";+			timer.innerHTML = "quarantine ends in " ++				displayUnit(h,"hour") + " " ++				displayUnit(m,"minute")+		} else {+			img.className = "safe";+			timer.innerHTML = "quarantine completed";+		}+	}++	setTimeout(animate,10000); // keep updating every 10s+}++function validateform() {+	var surfaces=document.getElementsByClassName("surface");+	var sok=false;+	for (var i=0,l=surfaces.length;i<l;i++) {+		if (surfaces[i].checked) {+			sok=true;+		}+	}+	photo=document.getElementsByName("photo")[0];+	if (photo.value.length == 0) {+		alert("Please take a photo of the thing you want to quarantine.");+		event.preventDefault();+	}+	else {+		if (! sok) {+			alert("Please indicate what the surface of the item is made of.");+			event.preventDefault();+		}+	}+}

@@ -0,0 +1,56 @@+footer {+	padding: 24px;+	margin: 0 auto;+	background-color: #EFEFEF;+	width: 100%;+	box-sizing: border-box;+}++h1 {+	font-size: calc(16px + (26 - 16) * ((100vw - 300px) / (1600 - 300)));+}++img {+	max-width: 50%;+	height: auto;+}++.timer {+	margin: 10px;+}++.safe {+	margin: 10px;+	display: block;+	background: #cca92c;+	border: 3px solid lightgreen; +}++.infected {+	margin: 10px;+	display: block;+	background: #cca92c;+	box-shadow: 0 0 0 rgba(255,0,0, 0.4);+	animation: pulse 2s infinite;+	border: 3px solid red; +}++@-webkit-keyframes pulse {+	0% { -webkit-box-shadow: 0 0 0 0 rgba(255,0,0, 0.4); }+	70% { -webkit-box-shadow: 0 0 0 10px rgba(255,0,0, 0); }+	100% { -webkit-box-shadow: 0 0 0 0 rgba(255,0,0, 0); }+}+@keyframes pulse {+	0% {+		-moz-box-shadow: 0 0 0 0 rgba(255,0,0, 0.4);+		box-shadow: 0 0 0 0 rgba(255,0,0, 0.4);+	}+	70% {+		-moz-box-shadow: 0 0 0 10px rgba(255,0,0, 0);+		box-shadow: 0 0 0 10px rgba(255,0,0, 0);+	}+	100% {+		-moz-box-shadow: 0 0 0 0 rgba(255,0,0, 0);+		box-shadow: 0 0 0 0 rgba(255,0,0, 0);+	}+}