diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,5 @@ +quarantimer (1.20200323) unstable; urgency=medium + + * First release. + + -- Joey Hess Mon, 23 Mar 2020 19:28:04 -0400 diff --git a/Config.hs b/Config.hs new file mode 100644 --- /dev/null +++ b/Config.hs @@ -0,0 +1,13 @@ +module Config where + +hostname :: String +hostname = "quarantimer.app" + +staticDir :: FilePath +staticDir = "static" + +maxImageSize :: Int +maxImageSize = 640 + +numImageCores :: Int +numImageCores = 1 diff --git a/Image.hs b/Image.hs new file mode 100644 --- /dev/null +++ b/Image.hs @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 by email with any bug reports, +questions, or patches. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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.) diff --git a/quarantimer.cabal b/quarantimer.cabal new file mode 100644 --- /dev/null +++ b/quarantimer.cabal @@ -0,0 +1,54 @@ +Name: quarantimer +Version: 1.20200323 +Cabal-Version: >= 1.8 +Maintainer: Joey Hess +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 diff --git a/quarantimer.hs b/quarantimer.hs new file mode 100644 --- /dev/null +++ b/quarantimer.hs @@ -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) diff --git a/static/js.js b/static/js.js new file mode 100644 --- /dev/null +++ b/static/js.js @@ -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