diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2016 Johannes Gerer + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,45 @@ +# memis: efficient manual image sorting [![Build Status](https://travis-ci.org/johannesgerer/memis.svg?branch=master)](https://travis-ci.org/johannesgerer/memis) [![Hackage](https://img.shields.io/hackage/v/Lykah.svg)](https://hackage.haskell.org/package/Lykah) + +*memis* is a little tool written in Haskell. It allows to efficiently +rename and sort image files into directories, via an intelligent web-interface. + +Supported operations: + +* moving into a folder +* creating new subfolders +* deletion +* rotation +* entering dates +* specifying the order of documents with equal dates + +## Alternatives + +This software tries to be better than its alternatives: + +* [Photosift](http://www.rlvision.com/photosift/about.asp) +* [Manual Imagesort](https://sourceforge.net/projects/manualimagesort/) +* [ImgSorter](https://sourceforge.net/projects/imgsorter/?source=directory) +* [XnViewMP](http://www.xnview.com/en/xnviewmp/) +* [Zoner Photo Studio Free](https://free.zoner.com/) + +Do you now another program that should be on this list? + +## Installation + +```shell +stack install +``` + +## Usage + +First start the server + +```shell +memis [source folder with images] [target folder] +``` + +and then navigate to [`http://localhost:8081`](http://localhost:8081). + +## Screenshot + +![screenshot](screen.png) 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/memis.cabal b/memis.cabal new file mode 100644 --- /dev/null +++ b/memis.cabal @@ -0,0 +1,54 @@ +name: memis +version: 0.1.1 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +maintainer: Johannes Gerer +homepage: http://johannesgerer.com/memis +synopsis: Memis Efficient Manual Image Sorting +description: + Memis allows to efficiently rename and sort image files into directories, via an intelligent web-interface. + . + See on Github. +category: Data +author: Johannes Gerer +extra-source-files: + README.md + stack.yaml + +executable memis + main-is: Main.hs + build-depends: + aeson >=0.11.2.1 && <0.12, + base >=4.9.0.0 && <4.10, + blaze-html >=0.8.1.3 && <0.9, + blaze-markup >=0.7.1.1 && <0.8, + bytestring >=0.10.8.1 && <0.11, + containers >=0.5.7.1 && <0.6, + directory >=1.2.3.0 && <1.3, + filemanip >=0.3.6.3 && <0.4, + filepath >=1.4.1.0 && <1.5, + http-types >=0.9.1 && <0.10, + mime-types >=0.1.0.7 && <0.2, + process >=1.4.2.0 && <1.5, + process-extras >=0.4.1.4 && <0.5, + regex-compat >=0.95.1 && <0.96, + regex-pcre-builtin >=0.94.4.8.8.35 && <0.95, + regex-tdfa >=1.2.2 && <1.3, + safe >=0.3.10 && <0.4, + simple >=0.11.1 && <0.12, + split >=0.2.3.1 && <0.3, + text >=1.2.2.1 && <1.3, + transformers >=0.5.2.0 && <0.6, + unordered-containers >=0.2.7.2 && <0.3, + utf8-string >=1.0.1.1 && <1.1, + wai >=3.2.1.1 && <3.3, + wai-extra >=3.0.19 && <3.1, + wai-middleware-static >=0.8.1 && <0.9, + warp >=3.2.9 && <3.3 + default-language: Haskell2010 + other-extensions: FlexibleInstances ScopedTypeVariables + FlexibleContexts OverloadedStrings NoMonomorphismRestriction + hs-source-dirs: src + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +import Control.Arrow +import qualified Control.Exception as E +import Control.Monad +import Control.Monad.Trans.Class +import Data.Aeson +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as L +import qualified Data.ByteString.UTF8 as B +import Data.Char +import qualified Data.HashMap.Strict as M +import Data.List hiding (find) +import Data.List.Split +import Data.Maybe +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Types +import Network.Mime +import Network.Wai +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.RequestLogger +import Network.Wai.Middleware.Static +import Safe +import System.Directory +import System.Environment +import System.Exit +import System.FilePath +import System.FilePath.Find +import System.Process (proc,readProcessWithExitCode) +import System.Process.ByteString.Lazy hiding (readProcessWithExitCode) +import Text.Blaze.Html.Renderer.Utf8 +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Printf +import Text.Read (readEither) +import Text.Regex +import Text.Regex.TDFA +import Web.Frank +import Web.Simple hiding (hoistEither,body) + +port = 8081 :: Int +targetD = "/home/data/schriftverkehr/aktuell" +sourceD = "/home/data/schriftverkehr/Unsortiert" + +javascript x = H.script H.! A.src x $ mempty +stylesheet x = H.link H.! A.rel "stylesheet" H.! A.type_ "text/css" H.! A.href x + +app2 :: String -> String -> Application +app2 target source = controllerApp () $ do + get "/" $ do + dirs <- lift $ targetDirs target + img <- lift (images source) + respond $ okHtml $ body dirs $ H.unsafeByteString $ mconcat + ["var imgs = ", L.toStrict $ encode + $ (\x -> M.fromList [("id"::String,x)]) <$> img ] + get "/img" $ do + f :: String <- queryParam' "id" + size :: Maybe String <- queryParam "size" + let scale size = do + (_,stdout,_) <- lift $ readCreateProcessWithExitCode + (proc "/usr/bin/convert" [f,"-filter","Lagrange" + ,"-resize",size,"-"]) "" + respond $ ok (defContentType f) stdout + if source `isPrefixOf` f then maybe (respond $ file f) scale size + else error $ printf "%s not in %s" f source + post "/apply" $ do + (params,_) <- parseForm + let a = either (\x -> error $ "decode failed: " ++ x) id + $ eitherDecodeStrict' $ lookupJust "imgs" params :: [Action] + runIt x = E.handle (\e-> return $ show (e::E.SomeException)) $ + x (target,source) + respond . okHtml . mconcat . fmap L.fromString =<< lift (mapM runIt a) + get "/mkdir" $ do + name :: String <- queryParam' "name" + resp <- lift $ E.handle + (\e->return $ L.fromString $ show (e::E.SomeException)) $ do + createDirectoryIfMissing True $ target name + renderHtml <$> targetDirs target + respond . okHtml $ resp + + +type Action = (String,String) -> IO String + +instance FromJSON Action where + parseJSON (Object v) = do + old <- v .: "id" + let fileO = takeFileName old + convertDate "delete" = Right $ "delete_" ++ fileO + convertDate s = (++ takeExtension old) . intercalate "-" + <$> mapM form (reverse . splitOn "." $ s) + form d = printf "%02i" <$> left (printf "date '%s': %s" d :: String -> String) + (readEither d :: Either String Int) + file <- maybe (Right fileO) convertDate <$> v .:? "date" + dir <- maybe (return $ takeDirectory old) (.: "id") =<< v .:? "dir" + angle <- v .:? "angle" + return $ \(target,source) -> do + msg <- rotate old angle + let rename f = if dir f == old then return "" else do + new <- (dir ) <$> getUnusedFilename [target,source] f + exis <- doesFileExist new + when (exis || not (target `isPrefixOf` new || source `isPrefixOf` new)) $ + error $ "something went wrong: " ++ show (old,dir,f,new) + renameFile old new + return $ printf "%s -> %s\n" old new + rename :: String -> IO String + return . (msg ++) =<< do + either (return . printf "Error handling %s: %s\n" old) rename file + + + +rotate :: String -> Maybe Int -> IO String +rotate _ Nothing = pure "" +rotate f (Just angle) = g <$> readProcessWithExitCode + "/usr/bin/gm" ["mogrify","-rotate", show angle, f] "" + where g (ExitSuccess,_,_) = printf "Rotated by %s by %d degrees\n" f angle + g (_,_,err) = err + + +getUnusedFilename dirs f = do + l <- concat <$> forM dirs (find always $ fileType ==? RegularFile) + return . r . succ . headDef 0 . sortBy (flip compare) . (g =<<) $ l + where core [] = [takeBaseName f, "" , takeExtension f] + core x = tail x + [b,_,e] = core $ m f + m = matches "(.*)_([0-9]+)(\\.[^.]+)?" + r c = printf "%s_%03i%s" b c e :: String + g s = case m (takeFileName s) of + [_,b2,c,e2] -> if b2 /= b || e2 /= e then [] + else [read c :: Int] + [] -> [] + +matches r s = getAllTextSubmatches $ (s::String) =~ (r:: String) :: [String] + +body dirs script =renderHtml $ H.docTypeHtml $ do + H.head $ do + H.meta H.! A.charset "UTF-8" + stylesheet "//ajax.googleapis.com/ajax/libs/jqueryui/1.11.4/themes/smoothness/jquery-ui.css" + stylesheet "style.css" + javascript "//ajax.googleapis.com/ajax/libs/jquery/2.2.2/jquery.min.js" + javascript "//ajax.googleapis.com/ajax/libs/jqueryui/1.11.4/jquery-ui.min.js" + H.script script + javascript "script.js" + H.body $ do + H.span H.! A.id "largeSpan" $ do + H.div "" + H.span H.! A.id "input" $ "" + H.h4 "" + H.span H.! A.id "imgSpan" $ "" + H.span H.! A.id "large" H.! A.class_ "imgBorder" $ "" + H.span H.! A.id "dirs" $ do + H.h4 $ H.preEscapedString " " + dirs + H.span H.! A.id "help" $ do + H.h4 "Key Bindings" + H.table $ mapM_ (\(a, b) -> H.tr $ H.td a >> H.td b) + [("[Left]","Previous Image") + ,("[Right]","Next Image") + ,("[Home]","First Image") + ,("[End]","Last Image") + ,("[Shift + Left]","Move image to the previous location in the list") + ,("[Shift + Right]","Move image to the next location in the list") + ,("[Ctrl + ]","Indicate Up-Direction of image and goto next") + ,("[m]","Create directory") + ,("[Enter]","Use date from input field and goto next image") + ,("[Backspace]","Clear date input field") + ,("[Delete]","Clear date") + ,("[0-9],[space]","Enter date in format: 'day month' or 'day month year'") + ,("[d]","Mark image for deletion") + ] + H.span H.! A.id "help" $ do + H.h4 $ H.a H.! A.href "?" H.! A.onclick "return applyChanges();" $ "Apply changes" + +defContentType p = mimeByExt defaultMimeMap defaultMimeType $ T.pack p + +file p = responseFile + status200 [("Content-Type", defContentType p)] + p Nothing + + +a' =~? b = do + a <- a' + return ( a =~ (b :: String) :: Bool) + +targetDirs = fmap (toH . tC) . getDirs + +toH :: [T] -> H.Html +toH [] = return () +toH d = H.ul $ forM_ d $ \(T x cs) -> + H.li H.! A.id (fromString x) $ do + H.span $ H.string $ takeFileName x + toH cs + +getDirs dir = do + cs <- filter (/= dir) . sort + <$> find (depth ==? 0) (fileType ==? Directory) dir + -- print cs + return . T dir =<< mapM getDirs cs + +images dir = filter (/= dir) . sort + <$> find (depth ==? 0) ((fmap toLower <$> extension) =~? "\\.(jpg|jpeg|png)" + &&? (fileName /~? "delete_*") ) dir + +data T = T { tP :: FilePath, + tC :: [T]} deriving Show + + +main :: IO () +main = do + a <- getArgs + cur <- getCurrentDirectory + unless (length a == 2) $ do + putStrLn "usage:\n\n\tmemis [source folder] [target folder]" + exitFailure + let [s,t] = a + printf "Source: %s\nTarget: %s\nhttp://localhost:%d\n" s t port + run port + . logStdoutDev + . staticPolicy (addBase $ cur "static") + $ app2 t s diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,4 @@ +resolver: lts-7.16 +packages: +- '.' +pvp-bounds: both