Initial commit

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
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..1a05183
--- /dev/null
+++ b/LICENSE
@@ -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"