diff options
| -rw-r--r-- | ChangeLog.md | 3 | ||||
| -rw-r--r-- | LICENSE | 30 | ||||
| -rw-r--r-- | README.md | 1 | ||||
| -rw-r--r-- | Setup.hs | 2 | ||||
| -rw-r--r-- | app/Main.hs | 19 | ||||
| -rw-r--r-- | package.yaml | 67 | ||||
| -rw-r--r-- | src/Lib.hs | 302 | ||||
| -rw-r--r-- | src/index.html | 33 | ||||
| -rw-r--r-- | stack.yaml | 69 | ||||
| -rw-r--r-- | test/Spec.hs | 2 |
10 files changed, 528 insertions, 0 deletions
diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..a4a3d6f --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for simghost + +## Unreleased changes @@ -0,0 +1,30 @@ +Copyright Daniel Schadt (c) 2020 + +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. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +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 +OWNER 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.md b/README.md new file mode 100644 index 0000000..3024b14 --- /dev/null +++ b/README.md @@ -0,0 +1 @@ +# simghost diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..46bd5a3 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,19 @@ +module Main where + +import Lib +import Control.Exception +import Data.Aeson +import Data.Maybe +import qualified Data.ByteString.Lazy as BS + + +loadSettings :: IO Settings +loadSettings = do + contents <- try (BS.readFile "settings.json") :: IO (Either SomeException BS.ByteString) + return (either (const defaultSettings) (fromJust . decode) contents) + + +main :: IO () +main = do + settings <- loadSettings + runApp settings imgHostMain diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..f0c96a8 --- /dev/null +++ b/package.yaml @@ -0,0 +1,67 @@ +name: simghost +version: 0.1.0.0 +github: "Kingdread/simghost" +license: BSD3 +author: "Daniel Schadt" +maintainer: "daniel@kingdread.de" +copyright: "2020 Daniel Schadt" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at <https://github.com/Kingdread/simghost#readme> + +dependencies: +- base >= 4.7 && < 5 +- mtl +- cgi +- file-embed +- aeson +- bytestring +- unordered-containers +- text +- filepath +- random +- time +- bcrypt +- base64-bytestring +- directory + +library: + source-dirs: src + +executables: + simghost-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - simghost + +tests: + simghost-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - simghost + +ghc-options: -Wall -O2 -static -threaded +cc-options: -static +ld-options: -static -pthread +extra-lib-dirs: +- /home/daniel/Coding/simghost/.stack-work/lib diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..2b5f0a1 --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +{-| +Description : Simple image hosting +Copyright : (c) Daniel, 2020 +License : BSD-3 +Maintainer : kingdread@gmx.de +-} + +module Lib + ( -- * Data structures + App + , runApp + , Settings(..) + , defaultSettings + , Metadata(..) + , Seconds + -- * Entry points + , imgHostMain + , handleUpload + , handleCleanup + -- * Other functions + , checkAuthorization + , randomName + , validChars + , indexPage + , ask + , asks + , getImageData + , saveFile + ) where + + +import Data.ByteString.Char8 (pack) +import Control.Applicative +import Control.Monad +import Control.Monad.Reader hiding (ask, asks) +import Crypto.BCrypt +import Data.Aeson +import Data.Aeson.Types +import Data.FileEmbed +import Data.Maybe +import Data.Time.Clock.System +import Data.Traversable +import GHC.Generics +import Network.CGI +import System.Directory +import System.FilePath +import System.Random + +import qualified Control.Monad.Reader +import qualified Data.ByteString.Base64.Lazy as B64 +import qualified Data.ByteString.Lazy as BS +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +-- | We are dealing with seconds when talking about durations, hence the type +-- alias. +type Seconds = Integer + + +-- | Metadata of a stored file. +data Metadata = Metadata { creator :: String + -- ^ Username of the creator. + , createdAt :: Integer + -- ^ Unix timestamp of the creation time. + , endOfLife :: Integer + -- ^ Unix timestamp of the expiration time. + } deriving (Show, Eq, Generic, FromJSON, ToJSON) + +isEternal :: Metadata -> Bool +isEternal Metadata{..} = createdAt == endOfLife + + +-- | Application settings, should be read from a file at startup. +data Settings = Settings { outputDir :: FilePath + -- ^ Output directory for new images. + , defaultDuration :: Seconds + -- ^ Default lifetime of new images. + , nameLength :: Int + -- ^ Length (in characters) of the random identifier for images. + , users :: [(String, String)] + -- ^ A list of (user, password) pairs. + -- + -- Passwords are expected to be hashed using bcrypt. + } deriving (Show) + + +instance FromJSON Settings where + parseJSON = withObject "settings" $ \o -> do + outputDir <- o .:? "outputDir" .!= "img" + defaultDuration <- o .:? "defaultDuration" .!= 0 + nameLength <- o .:? "nameLength" .!= 20 + users <- (o .:? "users" .!= object []) >>= parseUserDict + return Settings{..} + + +parseUserDict :: Value -> Parser [(String, String)] +parseUserDict = + withObject "users" $ \o -> + for (HM.toList o) $ \(user, pw) -> do + password <- parseJSON pw + return (T.unpack user, password) + + +instance ToJSON Settings where + toJSON Settings{..} = object [ "outputDir" .= outputDir + , "defaultTimeout" .= defaultDuration + , "nameLength" .= nameLength + , "users" .= formatUsers users + ] + where + formatUsers :: [(String, String)] -> Object + formatUsers = HM.fromList . map (\(user, pw) -> (T.pack user, toJSON pw)) + + +-- | Return the default settings. +defaultSettings :: Settings +defaultSettings = case fromJSON $ object [] of + Success a -> a + Error s -> error s + + +-- | The application monad stack. +-- +-- This includes the CGI monad, IO and a reader to access the (global) +-- application settings. +type App a = CGIT (ReaderT Settings IO) a + + +-- | Run the given 'App' with the given 'Settings'. +runApp :: Settings -> App CGIResult -> IO () +runApp settings app = runReaderT (runCGI (handleErrors app)) settings + + +-- | HTML source code of the index page. +-- +-- This is included at compile time from @src/index.html@. +indexPage :: String +indexPage = $(embedStringFile "src/index.html") + + +-- | A lifted version of 'Control.Monad.Reader.ask'. +-- +-- Provides access to the 'Settings' instance in the 'App' monad stack. +ask :: App Settings +ask = lift Control.Monad.Reader.ask + + +-- | A lifted version of 'Control.Monad.Reader.asks'. +-- +-- Provides access to the 'Settings' instance, but applies a function before +-- returning the value: +-- +-- > directory <- asks outputDir +asks :: (Settings -> a) -> App a +asks f = fmap f ask + + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe = either (const Nothing) Just + + +chooseRandom :: (RandomGen g) => [a] -> g -> (a, g) +chooseRandom inp gen = let (idx, nextGen) = randomR (0, length inp - 1) gen in + (inp !! idx, nextGen) + + +-- | Valid characters for filename creation. +validChars :: String +validChars = ['a'..'z'] ++ ['A'..'Z'] + + +-- | Creates a random filename. +-- +-- This uses the IO standard random generator to generate a name. +randomName :: App String +randomName = asks nameLength >>= \l -> + mapM (\_ -> liftIO $ getStdRandom (chooseRandom validChars)) [1..l] + + +-- | Save the given file in the correct output directory. +saveFile :: BS.ByteString + -- ^ The file content to be saved, i.e. the image data. + -> String + -- ^ The file extension (including dot), or an empty string. + -> Seconds + -- ^ The duration until the file should expire, or 0. + -> String + -- ^ The user name of the user that saved the file. + -> App String + -- ^ Returns the file name that was used to save the file. +saveFile content extension duration username = do + filename <- (++ extension) <$> randomName + dir <- asks outputDir + let outputPath = dir </> filename + liftIO $ BS.writeFile outputPath content + currentTime <- liftIO getSystemTime + let eol = currentTime { systemSeconds = systemSeconds currentTime + fromInteger duration } + metadata = Metadata { creator = username + , createdAt = toInteger $ systemSeconds currentTime + , endOfLife = toInteger $ systemSeconds eol + } + liftIO $ BS.writeFile (outputPath ++ ".meta") (encode metadata) + return filename + + +-- | Check the authorization data. +checkAuthorization :: [(String, String)] + -- ^ The (user, password) list. + -> Maybe String + -- ^ The given username. + -> Maybe String + -- ^ The given password. + -> Bool + -- ^ The authorization result. +checkAuthorization users (Just user) (Just password) = case lookup user users of + Just p -> validatePassword (pack p) (pack password) + Nothing -> False +checkAuthorization _ _ _ = False + + +-- | Get the image data from the current request. +-- +-- This first checks if some raw content is given in the @imagecontent@ field +-- (i.e. data from a pasted image), and afterwards checks @imagefile@ (i.e. the +-- file selected in the file chooser). +getImageData :: App (Maybe BS.ByteString) +getImageData = do + rawData <- getInputFPS "imagecontent" + case rawData of + Just d | d /= "" -> return . rightToMaybe $ B64.decode d + _ -> getInputFPS "imagefile" + + +cleanupFile :: FilePath -> App () +cleanupFile fname = do + dir <- asks outputDir + currentTime <- systemSeconds <$> liftIO getSystemTime + content <- liftIO $ BS.readFile (dir </> fname) + case decode content :: (Maybe Metadata) of + Just metadata | isEternal metadata -> return () + Just metadata | endOfLife metadata < toInteger currentTime -> do + logCGI ("Deleting " ++ fname) + liftIO $ removeFile (dir </> fname) + liftIO $ removeFile (dir </> takeBaseName fname) + _ -> return () + + +-- | Performs the cleanup by deleting expired images. +handleCleanup :: App CGIResult +handleCleanup = do + dir <- asks outputDir + files <- liftIO $ getDirectoryContents dir + let metaFiles = filter ((== ".meta") . takeExtension) files + forM_ metaFiles cleanupFile + output "Cleaning up" + + +-- | Performs a file upload. +handleUpload :: App CGIResult +handleUpload = do + users <- asks users + outdir <- asks outputDir + user <- getInput "username" + password <- getInput "password" + let authorized = checkAuthorization users user password + if authorized then do + filecontent <- getImageData + filename <- getInputFilename "imagefile" + duration :: Maybe Integer <- readInput "duration" + let finfo = (,,) <$> filecontent <*> (filename <|> Just "") <*> duration + case finfo of + Just (content, name, dur) -> do + savedFileName <- saveFile content (takeExtension name) dur (fromJust user) + redirect $ outdir </> savedFileName + Nothing -> do + setStatus 400 "Missing data" + output "Invalid request" + else do + setStatus 401 "Unauthorized" + output "Invalid credentials" + +-- | Main entry point of the application. +-- +-- Depending on the given parameters, this either dispatches to +-- 'handleCleanup', 'handleUpload' or just returns the 'indexPage'. +imgHostMain :: App CGIResult +imgHostMain = do + cleanup <- getInput "cleanup" + case cleanup of + Just _ -> handleCleanup + Nothing -> do + method <- requestMethod + case method of + "POST" -> handleUpload + _ -> output indexPage diff --git a/src/index.html b/src/index.html new file mode 100644 index 0000000..97191f0 --- /dev/null +++ b/src/index.html @@ -0,0 +1,33 @@ +<html> + <head> + <title>Simple Image Host</title> + </head> + <body> + <form method="POST" enctype="multipart/form-data"> + <input type="hidden" name="imagecontent"> + <table> + <tr><td colspan="2"><input type="file" name="imagefile"></td></tr> + <tr><td colspan="2"><div contenteditable="true" id="paster">Paste image</div></td></tr> + <tr><td>Duration:</td><td><input type="number" name="duration" value="500"></td></tr> + <tr><td>User:</td><td><input type="text" name="username"></td></tr> + <tr><td>Password:</td><td><input type="password" name="password"></td></tr> + <tr><td></td><td><input type="submit" value="Upload"></td></tr> + </table> + </form> + <script> + document.querySelector("#paster").onpaste = function(e) { + for (let item of e.clipboardData.items) { + if (item.type.startsWith("image/")) { + console.log(item); + let data = document.querySelector("input[name=imagecontent]"); + item.getAsFile().arrayBuffer().then((bytes) => { + data.value = btoa(String.fromCharCode(...new Uint8Array(bytes))); + console.log(bytes); + }); + } + } + e.preventDefault(); + }; + </script> + </body> +</html> diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..557f437 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,69 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-15.0 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +extra-deps: +- /home/daniel/src/multipart +- cgi-3001.5.0.0 +- ginger-0.9.1.0 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.2" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" |