memis (empty) → 0.1.1
raw patch · 6 files changed
+352/−0 lines, 6 filesdep +aesondep +basedep +blaze-htmlsetup-changed
Dependencies added: aeson, base, blaze-html, blaze-markup, bytestring, containers, directory, filemanip, filepath, http-types, mime-types, process, process-extras, regex-compat, regex-pcre-builtin, regex-tdfa, safe, simple, split, text, transformers, unordered-containers, utf8-string, wai, wai-extra, wai-middleware-static, warp
Files
- LICENSE +21/−0
- README.md +45/−0
- Setup.hs +2/−0
- memis.cabal +54/−0
- src/Main.hs +226/−0
- stack.yaml +4/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,45 @@+# memis: efficient manual image sorting [](https://travis-ci.org/johannesgerer/memis) [](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++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ memis.cabal view
@@ -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 <oss@johannesgerer.com>+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 <https://github.com/johannesgerer/memis Readme> 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+
+ src/Main.hs view
@@ -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 + <Arrow>]","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
+ stack.yaml view
@@ -0,0 +1,4 @@+resolver: lts-7.16+packages:+- '.'+pvp-bounds: both