68 Commits

Author SHA1 Message Date
a25f92e4ec GTK: pre-set input field when renaming files 2016-05-09 00:45:47 +02:00
4254c80a64 TESTS: add missing utf8-string dependency 2016-05-09 00:21:54 +02:00
ca9cf51e3c TESTS: remove side effects from CopyFileOverwriteSpec
And also compare the results.
2016-05-09 00:21:18 +02:00
29f4dc67b6 TESTS: use specDir to refer to the test directories 2016-05-09 00:16:26 +02:00
a91b4859d0 TESTS: fix getDirsFilesSpec 2016-05-08 23:46:05 +02:00
c89d6b945c TESTS: use hspec-discover 2016-05-08 23:45:51 +02:00
5b6a342a9e LIB/TESTS: fix moveFileOverwrite and add tests
We must not allow to move a file to a directory, deleting that
directory and effectively changing the filetype.
2016-05-08 23:20:00 +02:00
8646a6338c LIB/GTK: simplify error handling, add 'reactOnError' 2016-05-08 23:06:40 +02:00
db16dcbb5d GTK: fix renameF callback 2016-05-08 20:14:39 +02:00
3af8b36940 GTK: adjust to new LIB API and refactor file error handling
This restructures large parts of the GUI-wise error handling code
and makes it more fine-grained, so the user can react appropriately
to exceptions.
2016-05-08 20:14:30 +02:00
9c6cf51825 LIB: refactor FileOperation and related Errors
* move FileOperation/Copy/Move types to its own UtilTypes module
* remove runFileOp, since it's hard to really do the correct
  thing here for all possible exceptions... instead, let the
  GUI logic handle this
* introduce copyDirRecursiveOverwrite, copyFileOverwrite and
  easyCopyOverwrite
* use our own throwSameFile on functions to distinguish between
  "same file" and "file already exists"
* don't follow destination in copyFile* either
* improve throwSameFile, by examining device and file ids
* add isWritable
* improve documentation
* adjust and fix tests
2016-05-08 18:48:17 +02:00
d58fd6e6f0 LIB: add copyFileOverwrite 2016-05-08 12:48:03 +02:00
1487351f29 TESTS: restructure files 2016-05-03 13:27:10 +02:00
e56c345156 TESTS: general refactoring 2016-05-03 13:13:07 +02:00
37773383af TESTS: refacotr 2016-05-03 12:44:05 +02:00
8b0e59faa7 LIB: improve documentation 2016-05-03 11:55:34 +02:00
6ec455b515 LIB: make deleteDirRecursive more robust
We now try 'deleteDir' first and only start recursive removal
if that fails.
2016-05-03 11:54:25 +02:00
4a86b4d2cf TESTS: add missing deleteDirRecursiveSpec, minor cleanup 2016-05-03 11:53:46 +02:00
70270d60ba TESTS: improve deleteDirSpec 2016-05-03 11:53:07 +02:00
bd70b8751a TESTS: add deleteDirRecursiveSpec 2016-05-03 11:52:36 +02:00
31fe08195f TESTS: add deleteDirSpec 2016-05-03 11:19:13 +02:00
c84512e3b3 TESTS: add deleteFileSpec 2016-05-02 23:10:22 +02:00
9a11e35be0 TESTS: add getDirsFilesSpec 2016-05-02 22:52:10 +02:00
7e8d465d81 LIB: improve documentation 2016-05-02 22:19:19 +02:00
526db2cbb7 GTK: fix opening symlinks that point to directories 2016-05-02 22:13:33 +02:00
5670b160d8 TESTS: add getFileTypeSpec 2016-05-02 22:13:19 +02:00
ac41b053e3 LIB: fix legacy comment 2016-05-02 20:51:59 +02:00
37516306d3 LIB: improve documentation formatting 2016-05-02 20:49:08 +02:00
71cee4019b LIB: fix grammar 2016-05-02 20:38:59 +02:00
94bcc12224 TESTS: improve naming, reorder slightly 2016-05-02 20:36:58 +02:00
782abe2584 LIB: improve documentation 2016-05-02 20:36:22 +02:00
3e5777bf3a TESTS: fix normalDirPerms 2016-05-02 19:54:47 +02:00
c76c27288d TESTS: also test directories with no permissions at all 2016-05-02 19:50:38 +02:00
98e8104602 TESTS: fix folder permissions for tests on non-writable folders 2016-05-02 19:30:00 +02:00
95b49f41dd TESTS: run all tests twice to detect state skew 2016-05-02 19:18:15 +02:00
b3b239d4c9 LIB: rm redundant imports 2016-05-02 19:14:52 +02:00
c5afe976cf GTK: adjust to new APIs, CopyMode functionality is broken for now! 2016-05-02 19:14:41 +02:00
f48c3ecfe4 Update hpath submodule 2016-05-02 19:10:57 +02:00
ce1383dc11 TESTS: first set of hspec tests 2016-05-02 19:08:46 +02:00
47cd43dba6 LIB: refactor large parts of the API
This makes the FileOperations module more low-level, since we now
handle everything via 'Path Abs' and only leave 'File a' for
e.g. GUI purposes.

Also fixes various bugs in the Errors module.

This depends on custom changes in posix-paths.
2016-05-02 19:06:53 +02:00
hasufell
1be9ecb44e Use hinotify-bytestring fork 2016-05-01 04:37:34 +02:00
251a20e881 GTK: minor fixes 2016-04-24 20:01:22 +02:00
c29693fbd0 GTK: allow to open terminal at current directory
TODO: terminal needs to be configurable
2016-04-24 20:00:34 +02:00
9420af15a1 README: update image 2016-04-24 18:48:13 +02:00
3008e4463b GTK: implement tabs wrt #45
This also restructures the meaning of MyGUI and MyView.
They are now more strictly a hierarchy and everything that may
be specific to a view (like urlBar) has been moved into the MyView
context.

In addition, this also fixes #42
2016-04-24 18:38:47 +02:00
hasufell
44fc047223 Minor addition in HACKING.md 2016-04-21 02:50:10 +02:00
hasufell
8348f34a4a Improve HACKING.md 2016-04-21 02:45:23 +02:00
a4c8995299 GTK: formatting and comments 2016-04-20 17:59:55 +02:00
0ff24002e5 GTK: avoid subsequent duplicate entries in history 2016-04-20 17:27:47 +02:00
7608d838aa GTK: improve history navigation
* increase maximum numbers of items in the history
* empty the "forward" history if we enter a directory
  via normal navigation
2016-04-20 17:20:04 +02:00
d432c2146b GTK: improve file property dialog
Adds the following fields:
* file type
* permissions
* link destination of symlink (if applicable)
2016-04-20 17:16:58 +02:00
064d5a1032 LIB/GTK: use strict data types where possible 2016-04-20 16:34:26 +02:00
39bc0cba24 GTK: tweak GUI appearance 2016-04-20 16:33:39 +02:00
07c5fa2d62 GTK: fix imports 2016-04-20 16:33:18 +02:00
5c57551438 GTK: restructure Callbacks.hs to make it more readable 2016-04-20 01:25:40 +02:00
3c6aca04b4 GTK: fix history when clicking on HOME button 2016-04-20 00:48:34 +02:00
9d572c8a6e GTK: remove obsolete void usage 2016-04-20 00:39:53 +02:00
680a75f5be GTK: implement rudimentary history support wrt #21
5 items back and forth only. Implemented via a simple
TVar ([], []). Might be improved in the future.
2016-04-20 00:38:22 +02:00
4b0e3ba89a Add symbolic link to hacking/HACKING.md 2016-04-19 21:17:17 +02:00
02f04d92f3 Fix missing whitespace in hsimport.hs prettyPrint String 2016-04-19 21:05:52 +02:00
a61b409486 GTK: implement fileinfo dialog wrt #32 2016-04-19 21:05:29 +02:00
a7ba20ae00 README: fix installation instructions 2016-04-18 01:59:46 +02:00
9b43814846 GTK: clear move buffer after move
Doesn't make sense to keep it since the buffer
will probably point to a non-existing file afterwards.
2016-04-18 01:02:18 +02:00
8b8c9a669f GTK: implement file drag and drop
Still doesn't work on multiple rows.

Also see #14
2016-04-18 00:51:45 +02:00
7f538f4fae Update hpath submodule 2016-04-18 00:28:10 +02:00
1d2bf37a44 GTK: implement creating new directories
And moving it with creating new files to a submenuitem.
2016-04-17 03:12:34 +02:00
2e16e0ae48 HACKING: add note about absolute paths 2016-04-17 01:44:53 +02:00
260e7ea01c HACKING: fix newlines in hsimport.hs 2016-04-17 01:41:36 +02:00
143 changed files with 3925 additions and 1056 deletions

3
.gitmodules vendored
View File

@@ -1,9 +1,6 @@
[submodule "3rdparty/hpath"] [submodule "3rdparty/hpath"]
path = 3rdparty/hpath path = 3rdparty/hpath
url = https://github.com/hasufell/hpath.git url = https://github.com/hasufell/hpath.git
[submodule "3rdparty/hinotify"]
path = 3rdparty/hinotify
url = https://github.com/hasufell/hinotify.git
[submodule "3rdparty/simple-sendfile"] [submodule "3rdparty/simple-sendfile"]
path = 3rdparty/simple-sendfile path = 3rdparty/simple-sendfile
url = https://github.com/hasufell/simple-sendfile.git url = https://github.com/hasufell/simple-sendfile.git

1
3rdparty/hinotify vendored

Submodule 3rdparty/hinotify deleted from 6751bf0cc8

2
3rdparty/hpath vendored

1
HACKING.md Symbolic link
View File

@@ -0,0 +1 @@
hacking/HACKING.md

View File

@@ -15,12 +15,20 @@ Design goals:
Screenshots Screenshots
----------- -----------
![Image missing](https://cloud.githubusercontent.com/assets/1241845/14584163/6dbef950-0439-11e6-8a6e-2352c048775e.png "hsfm-gtk") ![hsfm](https://cloud.githubusercontent.com/assets/1241845/14768900/06efd43c-0a4d-11e6-939e-6b067bdb47ce.png "hsfm-gtk")
Installation Installation
------------ ------------
``` ```
git submodule update --init --recursive
cabal sandbox init
cabal sandbox add-source 3rdparty/hpath
cabal sandbox add-source 3rdparty/hpath/3rdparty/posix-paths
cabal sandbox add-source 3rdparty/simple-sendfile
cabal install alex happy
export PATH="$(pwd)/.cabal-sandbox/bin:$PATH"
cabal install gtk2hs-buildtools
cabal install cabal install
``` ```

View File

@@ -2,113 +2,281 @@
<!-- Generated with glade 3.18.3 --> <!-- Generated with glade 3.18.3 -->
<interface> <interface>
<requires lib="gtk+" version="3.16"/> <requires lib="gtk+" version="3.16"/>
<object class="GtkGrid" id="fpropGrid">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="row_spacing">2</property>
<property name="column_spacing">2</property>
<property name="row_homogeneous">True</property>
<child>
<object class="GtkLabel" id="label1">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">File Name:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropFnEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">0</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Location:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label3">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Total Size:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropLocEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">1</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropTsEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">2</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Accessed:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">7</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Modified:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">6</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropModEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">6</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropAcEntry">
<property name="width_request">350</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">7</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">File Type:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropFTEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">3</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropPermEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">4</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Link Destination:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">5</property>
</packing>
</child>
<child>
<object class="GtkLabel" id="label8">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="halign">start</property>
<property name="margin_left">5</property>
<property name="label" translatable="yes">Permissions:</property>
<attributes>
<attribute name="weight" value="bold"/>
</attributes>
</object>
<packing>
<property name="left_attach">0</property>
<property name="top_attach">4</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="fpropLDEntry">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="margin_left">5</property>
<property name="margin_right">5</property>
<property name="margin_top">2</property>
<property name="margin_bottom">2</property>
<property name="editable">False</property>
</object>
<packing>
<property name="left_attach">1</property>
<property name="top_attach">5</property>
</packing>
</child>
</object>
<object class="GtkImage" id="image1"> <object class="GtkImage" id="image1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="stock">gtk-edit</property> <property name="stock">gtk-edit</property>
</object> </object>
<object class="GtkMenu" id="rcMenu">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="rcFileOpen">
<property name="label">gtk-open</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileExecute">
<property name="label">gtk-execute</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNew">
<property name="label">gtk-new</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileCut">
<property name="label">gtk-cut</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileCopy">
<property name="label">gtk-copy</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileRename">
<property name="label">Rename</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image1</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFilePaste">
<property name="label">gtk-paste</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileDelete">
<property name="label">gtk-delete</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
<object class="GtkImage" id="image2"> <object class="GtkImage" id="image2">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="stock">gtk-edit</property> <property name="stock">gtk-open</property>
</object> </object>
<object class="GtkImage" id="image3"> <object class="GtkImage" id="image3">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<property name="stock">gtk-cancel</property> <property name="stock">gtk-cancel</property>
</object> </object>
<object class="GtkImage" id="image4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property>
</object>
<object class="GtkImage" id="image5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property>
</object>
<object class="GtkApplicationWindow" id="rootWin"> <object class="GtkApplicationWindow" id="rootWin">
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child> <child>
@@ -130,33 +298,6 @@
<object class="GtkMenu" id="menu1"> <object class="GtkMenu" id="menu1">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarFileOpen">
<property name="label">gtk-open</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileExecute">
<property name="label">gtk-execute</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarFileNew">
<property name="label">gtk-new</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child> <child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem1"> <object class="GtkSeparatorMenuItem" id="separatormenuitem1">
<property name="visible">True</property> <property name="visible">True</property>
@@ -176,65 +317,6 @@
</child> </child>
</object> </object>
</child> </child>
<child>
<object class="GtkMenuItem" id="menubarEdit">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="label" translatable="yes">_Edit</property>
<property name="use_underline">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarEditCut">
<property name="label">gtk-cut</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditCopy">
<property name="label">gtk-copy</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditRename">
<property name="label">Move</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image2</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditPaste">
<property name="label">gtk-paste</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarEditDelete">
<property name="label">gtk-delete</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
</object>
</child>
</object>
</child>
<child> <child>
<object class="GtkMenuItem" id="menubarView"> <object class="GtkMenuItem" id="menubarView">
<property name="visible">True</property> <property name="visible">True</property>
@@ -244,24 +326,6 @@
<object class="GtkMenu" id="menu5"> <object class="GtkMenu" id="menu5">
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">False</property> <property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="menubarViewTree">
<property name="label">Tree View</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image4</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="menubarViewIcon">
<property name="label">Icon view</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image5</property>
<property name="use_stock">False</property>
</object>
</child>
</object> </object>
</child> </child>
</object> </object>
@@ -297,82 +361,27 @@
</packing> </packing>
</child> </child>
<child> <child>
<object class="GtkBox" id="box2"> <object class="GtkNotebook" id="notebook">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkButton" id="upViewB">
<property name="label">gtk-go-up</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkButton" id="homeViewB">
<property name="label">gtk-home</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkButton" id="refreshViewB">
<property name="label">gtk-refresh</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">3</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkScrolledWindow" id="mainScroll">
<property name="width_request">300</property>
<property name="height_request">500</property>
<property name="visible">True</property> <property name="visible">True</property>
<property name="can_focus">True</property> <property name="can_focus">True</property>
<property name="shadow_type">in</property>
<child> <child>
<placeholder/> <placeholder/>
</child> </child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
<child>
<placeholder/>
</child>
<child type="tab">
<placeholder/>
</child>
</object> </object>
<packing> <packing>
<property name="expand">True</property> <property name="expand">True</property>
@@ -430,4 +439,267 @@
</object> </object>
</child> </child>
</object> </object>
<object class="GtkImage" id="image4">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-in</property>
</object>
<object class="GtkImage" id="image5">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-out</property>
</object>
<object class="GtkImage" id="image6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-directory</property>
</object>
<object class="GtkImage" id="image7">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="stock">gtk-zoom-fit</property>
</object>
<object class="GtkMenu" id="rcMenu">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="rcFileOpen">
<property name="label">gtk-open</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileExecute">
<property name="label">gtk-execute</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNew">
<property name="label">gtk-new</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
<child type="submenu">
<object class="GtkMenu" id="menu6">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="rcFileNewRegFile">
<property name="label">gtk-file</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileNewDir">
<property name="label" translatable="yes">directory</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image6</property>
<property name="use_stock">False</property>
</object>
</child>
</object>
</child>
</object>
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem2">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileCut">
<property name="label">gtk-cut</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileCopy">
<property name="label">gtk-copy</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileRename">
<property name="label">Rename</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image1</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFilePaste">
<property name="label">gtk-paste</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileDelete">
<property name="label">gtk-delete</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileProperty">
<property name="label">gtk-properties</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="use_underline">True</property>
<property name="use_stock">True</property>
</object>
</child>
<child>
<object class="GtkSeparatorMenuItem" id="separatormenuitem3">
<property name="visible">True</property>
<property name="can_focus">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileView">
<property name="label">View</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image7</property>
<property name="use_stock">False</property>
<child type="submenu">
<object class="GtkMenu" id="menu2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkImageMenuItem" id="rcFileIconView">
<property name="label">icon view</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image4</property>
<property name="use_stock">False</property>
</object>
</child>
<child>
<object class="GtkImageMenuItem" id="rcFileTreeView">
<property name="label" translatable="yes">tree view</property>
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="image">image5</property>
<property name="use_stock">False</property>
</object>
</child>
</object>
</child>
</object>
</child>
</object>
<object class="GtkBox" id="viewBox">
<property name="visible">True</property>
<property name="can_focus">False</property>
<property name="orientation">vertical</property>
<child>
<object class="GtkBox" id="box2">
<property name="visible">True</property>
<property name="can_focus">False</property>
<child>
<object class="GtkEntry" id="urlBar">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="input_purpose">url</property>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkButton" id="upViewB">
<property name="label">gtk-go-up</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkButton" id="homeViewB">
<property name="label">gtk-home</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">2</property>
</packing>
</child>
<child>
<object class="GtkButton" id="refreshViewB">
<property name="label">gtk-refresh</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
<property name="use_stock">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="padding">2</property>
<property name="position">3</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="fill">True</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkScrolledWindow" id="mainScroll">
<property name="width_request">300</property>
<property name="height_request">500</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="shadow_type">in</property>
<child>
<placeholder/>
</child>
</object>
<packing>
<property name="expand">True</property>
<property name="fill">True</property>
<property name="position">1</property>
</packing>
</child>
</object>
</interface> </interface>

View File

@@ -1,25 +1,23 @@
HACKING # HACKING
=======
Check out the [issue tracker](https://github.com/hasufell/hsfm/issues) Check out the [issue tracker](https://github.com/hasufell/hsfm/issues)
if you don't know yet what you want to hack on. if you don't know yet what you want to hack on.
Coding style ## Coding style
------------
- match the sorroundings - match the sorroundings
- no overcomplicated pointfree style - no overcomplicated pointfree style
- normal indenting 2 whitespaces - normal indenting 2 whitespaces
- just make things pretty and readable - just make things pretty and readable
- use the provided [hsimport.hs](hsimport.hs) - you can use the provided [hsimport.hs](hsimport.hs)
Documentation ## Documentation
-------------
__Everything__ must be documented. :) __Everything__ must be documented. :)
Don't assume people know what you mean. Type signatures are not sufficient
documentation.
Hacking Guide ## Hacking Overview
-------------
The main data structure for the IO related File type is in The main data structure for the IO related File type is in
[HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which [HSFM.FileSystem.FileType](./../src/HSFM/FileSystem/FileType.hs#L93), which
@@ -28,6 +26,8 @@ should be seen as a library. This is the entry point where
and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302). and the File type in general [is constructed](./../src/HSFM/FileSystem/FileType.hs#L302).
The File type uses a safe Path type under the hood instead of Strings, The File type uses a safe Path type under the hood instead of Strings,
utilizing the [hpath](https://github.com/hasufell/hpath) library. utilizing the [hpath](https://github.com/hasufell/hpath) library.
Note that mostly only absolute paths are allowed on type level to improve
path and thread safety.
File operations (like copy, delete etc) are defined at File operations (like copy, delete etc) are defined at
[HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs) [HSFM.FileSystem.FileOperation](./../src/HSFM/FileSystem/FileOperations.hs)
@@ -52,3 +52,73 @@ following files:
* [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file * [HSFM.GUI.Gtk.MyGUI](./../src/HSFM/GUI/Gtk/MyGUI.hs): add initializers for the GUI buttons to be fetched from the GTK builder.xml file
* [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here * [HSFM.GUI.Gtk.Callbacks](./../src/HSFM/GUI/Gtk/Callbacks.hs): define the callbacks and the actual functionality here
## Concepts
### Path safety
Paths are usually represented in haskell libraries as `type FilePath = String`.
This is bad, because of a number of reasons:
* encoding issues, since the low-level representation of filepaths is in fact an array of C chars
* weak typing... we could pass arbitrary invalid/malicious filepaths or other random strings
* no information about any property at type level (e.g. is it an absolute path?)
* no filepath constructors that do sanity checks and proper parsing
* no guarantee whether the filepath is normalised or not or even valid
Because of that, the solution is:
* use `ByteString` under the hood
* wrap it inside `Path t` where `t` can be either `Abs` (for absolute), `Rel` (for relative) or `Fn` (for filename)
* construct filepaths via smart constructors only that reject certain paths (like `.` or `..`) and normalise the path
This leads to the following benefits:
* we have guarantees about whether a path is absolute or not, which is important for runtime safety in general, predictable behavior and thread safety
* we don't mess with the filepath representation we get from low-level posix functions, so encoding issues are pretty much out
* we can reason about filepaths and rely on them to be valid (don't confuse that with "they exist")
* filepath functions like `(</>)` are now predictable and safe in contrast to the version from the `filepath` package
The only problem with this approach is that most libraries are still String
based. Some provide dedicated `Foo.ByteString` modules though, but it
might be necessary to fork libraries.
We also need to keep track of the [Abstract FilePath proposal](https://ghc.haskell.org/trac/ghc/wiki/Proposal/AbstractFilePath).
Almost all paths in HSFM are only allowed to be absolute (`Path Abs`), unless
they are filenames (`Path Fn`) and processed for GUI purposes. This is as
already mentioned for the purpose of runtime safety, predictability and
thread safety.
### File IO safety
This is a pretty difficult problem. One thing to ensure safety on IO level
is simply the strong haskell type system, since we push everything
into our `File a` type and can then pattern match easily against the different
types of files.
The only problem with this approach is that we are examining a file at point
`a` in time, safe the information and then use that information further down
the call stack at point `b` in time, when the file information in memory
could already be out of date. There are two approaches to make this less
sucky:
* use the hinotify library on GUI level to refresh the view (and the File representation in memory) whenever the contents of a directory changes
* when we stuff something into the copy buffer, it is not saved as type `File a`, but as `Path Abs`... when the operation is finalized via `runFileOp`, then the file at the given path is read and the copy/move/whatnot function carried out immediately
This means we should only interact with the `HSFM.FileSystem.FileOperation`
module via the operation data types `FileOperation`, `Copy` and `Move` and
the `runFileOp` function. This doesn't completely solve the problem, but for
the rest we have to trust the posix functions to throw the proper exceptions.
In addition, we don't use the `directory` package, which is dangerous
and broken. Instead, we implement our own low-level wrappers around
the posix functions, so we have proper control over the internals
and know the possible exceptions.
### Exception handling
Exceptions are good. We don't want to wrap everything in Maybe/Either types
unless we want to handle failure immediately. Otherwise we need to make
sure that at least at some point IOExceptions are caught and visualized
to the user. This is often done via e.g. `withErrorDialog` which catches
`IOException` and `FmIOException`.
It's also important to clean up stuff like filedescriptors via
functions like `bracket` directly in our low-level code in case
something goes wrong.

View File

@@ -8,7 +8,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
where where
prettyPrint :: HS.ImportDecl -> String prettyPrint :: HS.ImportDecl -> String
prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) = prettyPrint (HS.ImportDecl sloc modname qual _ _ mpkg mas mspec) =
"import " ++ (ifStr qual "qualified") ++ "import " ++ (ifStr qual "qualified ") ++
(maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++ (maybe "" (\pkg -> " \"" ++ pkg ++ "\" ") mpkg) ++
getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++ getMN modname ++ (maybe "" (\name -> " as " ++ getMN name) $ mas) ++
specprint mspec specprint mspec
@@ -16,9 +16,9 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
specprint :: Maybe (Bool, [HS.ImportSpec]) -> String specprint :: Maybe (Bool, [HS.ImportSpec]) -> String
specprint Nothing = "" specprint Nothing = ""
specprint (Just (False, xs)) specprint (Just (False, xs))
= "\n (\n" ++ printImportSpecs xs ++ "\n )" = "\n (\n" ++ printImportSpecs xs ++ " )"
specprint (Just (True, xs)) specprint (Just (True, xs))
= "\n hiding (\n" ++ printImportSpecs xs ++ "\n )" = "\n hiding (\n" ++ printImportSpecs xs ++ " )"
printImportSpecs :: [HS.ImportSpec] -> String printImportSpecs :: [HS.ImportSpec] -> String
printImportSpecs ins printImportSpecs ins
@@ -26,7 +26,7 @@ main = hsimport $ defaultConfig { prettyPrint = prettyPrint
in " " ++ printSpec x ++ "\n" ++ go xs in " " ++ printSpec x ++ "\n" ++ go xs
where where
go [] = "" go [] = ""
go [x'] = " , " ++ printSpec x' go [x'] = " , " ++ printSpec x' ++ "\n"
go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs' go (x':xs') = " , " ++ printSpec x' ++ "\n" ++ go xs'
printSpec :: HS.ImportSpec -> String printSpec :: HS.ImportSpec -> String
printSpec = HS.prettyPrint printSpec = HS.prettyPrint

View File

@@ -27,6 +27,7 @@ library
HSFM.FileSystem.Errors HSFM.FileSystem.Errors
HSFM.FileSystem.FileOperations HSFM.FileSystem.FileOperations
HSFM.FileSystem.FileType HSFM.FileSystem.FileType
HSFM.FileSystem.UtilTypes
HSFM.Utils.IO HSFM.Utils.IO
HSFM.Utils.MyPrelude HSFM.Utils.MyPrelude
@@ -36,7 +37,7 @@ library
containers, containers,
data-default, data-default,
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
hinotify, hinotify-bytestring,
hpath, hpath,
mtl >= 2.2, mtl >= 2.2,
old-locale >= 1, old-locale >= 1,
@@ -66,6 +67,7 @@ executable hsfm-gtk
other-modules: other-modules:
HSFM.GUI.Glib.GlibString HSFM.GUI.Glib.GlibString
HSFM.GUI.Gtk.Callbacks HSFM.GUI.Gtk.Callbacks
HSFM.GUI.Gtk.Callbacks.Utils
HSFM.GUI.Gtk.Data HSFM.GUI.Gtk.Data
HSFM.GUI.Gtk.Dialogs HSFM.GUI.Gtk.Dialogs
HSFM.GUI.Gtk.Errors HSFM.GUI.Gtk.Errors
@@ -84,7 +86,7 @@ executable hsfm-gtk
filepath >= 1.3.0.0, filepath >= 1.3.0.0,
glib >= 0.13, glib >= 0.13,
gtk3 >= 0.14.1, gtk3 >= 0.14.1,
hinotify, hinotify-bytestring,
hpath, hpath,
hsfm, hsfm,
mtl >= 2.2, mtl >= 2.2,
@@ -111,3 +113,38 @@ executable hsfm-gtk
-threaded -threaded
-Wall -Wall
"-with-rtsopts=-N" "-with-rtsopts=-N"
Test-Suite spec
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
Hs-Source-Dirs: test
Main-Is: Main.hs
other-modules:
Spec
FileSystem.FileOperations.CopyDirRecursiveSpec
FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec
FileSystem.FileOperations.CopyFileSpec
FileSystem.FileOperations.CopyFileOverwriteSpec
FileSystem.FileOperations.CreateDirSpec
FileSystem.FileOperations.CreateRegularFileSpec
FileSystem.FileOperations.DeleteDirRecursiveSpec
FileSystem.FileOperations.DeleteDirSpec
FileSystem.FileOperations.DeleteFileSpec
FileSystem.FileOperations.GetDirsFilesSpec
FileSystem.FileOperations.GetFileTypeSpec
FileSystem.FileOperations.MoveFileSpec
FileSystem.FileOperations.MoveFileOverwriteSpec
FileSystem.FileOperations.RecreateSymlinkSpec
FileSystem.FileOperations.RenameFileSpec
Utils
GHC-Options: -Wall
Build-Depends: base
, HUnit
, bytestring
, hpath
, hsfm
, hspec >= 1.3
, process
, unix
, utf8-string

View File

@@ -17,6 +17,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |Provides error handling. -- |Provides error handling.
@@ -26,19 +27,27 @@ module HSFM.FileSystem.Errors where
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
( (
when forM
, forM , when
) )
import Data.ByteString import Data.ByteString
( (
ByteString ByteString
) )
import Data.Data
(
Data(..)
)
import Data.Typeable import Data.Typeable
import Foreign.C.Error import Foreign.C.Error
( (
getErrno getErrno
, Errno , Errno
) )
import GHC.IO.Exception
(
IOErrorType
)
import qualified HPath as P import qualified HPath as P
import HPath import HPath
( (
@@ -49,10 +58,15 @@ import HSFM.Utils.IO
import System.IO.Error import System.IO.Error
( (
catchIOError catchIOError
, ioeGetErrorType
) )
import qualified System.Posix.Directory.ByteString as PFD import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.FilePath import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
@@ -72,7 +86,7 @@ data FmIOException = FileDoesNotExist ByteString
| Can'tOpenDirectory ByteString | Can'tOpenDirectory ByteString
| CopyFailed String | CopyFailed String
| MoveFailed String | MoveFailed String
deriving (Typeable) deriving (Typeable, Eq, Data)
instance Show FmIOException where instance Show FmIOException where
@@ -106,6 +120,26 @@ instance Exception FmIOException
isDestinationInSource :: FmIOException -> Bool
isDestinationInSource (DestinationInSource _ _) = True
isDestinationInSource _ = False
isSameFile :: FmIOException -> Bool
isSameFile (SameFile _ _) = True
isSameFile _ = False
isFileDoesExist :: FmIOException -> Bool
isFileDoesExist (FileDoesExist _) = True
isFileDoesExist _ = False
isDirDoesExist :: FmIOException -> Bool
isDirDoesExist (DirDoesExist _) = True
isDirDoesExist _ = False
---------------------------- ----------------------------
--[ Path based functions ]-- --[ Path based functions ]--
@@ -126,28 +160,38 @@ throwDirDoesExist fp =
throwFileDoesNotExist :: Path Abs -> IO () throwFileDoesNotExist :: Path Abs -> IO ()
throwFileDoesNotExist fp = throwFileDoesNotExist fp =
whenM (doesFileExist fp) (throw . FileDoesExist unlessM (doesFileExist fp) (throw . FileDoesNotExist
. P.fromAbs $ fp) . P.fromAbs $ fp)
throwDirDoesNotExist :: Path Abs -> IO () throwDirDoesNotExist :: Path Abs -> IO ()
throwDirDoesNotExist fp = throwDirDoesNotExist fp =
whenM (doesDirectoryExist fp) (throw . DirDoesExist unlessM (doesDirectoryExist fp) (throw . DirDoesNotExist
. P.fromAbs $ fp) . P.fromAbs $ fp)
throwSameFile :: Path Abs -- ^ will be canonicalized -- |Uses `isSameFile` and throws `SameFile` if it returns True.
-> Path Abs -- ^ will be canonicalized throwSameFile :: Path Abs
-> Path Abs
-> IO () -> IO ()
throwSameFile fp1 fp2 = do throwSameFile fp1 fp2 =
fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1 whenM (sameFile fp1 fp2)
-- TODO: clean this up... if canonicalizing fp2 fails we try to (throw $ SameFile (P.fromAbs fp1) (P.fromAbs fp2))
-- canonicalize `dirname fp2`
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
(\_ -> fmap P.fromAbs -- |Check if the files are the same by examining device and file id.
$ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2) -- This follows symbolic links.
<$> (P.canonicalizePath $ P.dirname fp2)) sameFile :: Path Abs -> Path Abs -> IO Bool
when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2') sameFile fp1 fp2 =
P.withAbsPath fp1 $ \fp1' -> P.withAbsPath fp2 $ \fp2' ->
handleIOError (\_ -> return False) $ do
fs1 <- getFileStatus fp1'
fs2 <- getFileStatus fp2'
if ((PF.deviceID fs1, PF.fileID fs1) ==
(PF.deviceID fs2, PF.fileID fs2))
then return True
else return False
-- |Checks whether the destination directory is contained -- |Checks whether the destination directory is contained
@@ -159,41 +203,45 @@ throwDestinationInSource :: Path Abs -- ^ source dir
-- must exist -- must exist
-> IO () -> IO ()
throwDestinationInSource source dest = do throwDestinationInSource source dest = do
source' <- P.canonicalizePath source
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest) dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
<$> (P.canonicalizePath $ P.dirname dest) <$> (P.canonicalizePath $ P.dirname dest)
dids <- forM (P.getAllParents dest') $ \p -> do dids <- forM (P.getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p) fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
return (PF.deviceID fs, PF.fileID fs) return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x)) sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getSymbolicLinkStatus (P.fromAbs source') $ PF.getFileStatus (P.fromAbs source)
when (elem sid dids) when (elem sid dids)
(throw $ DestinationInSource (P.fromAbs dest) (throw $ DestinationInSource (P.fromAbs dest)
(P.fromAbs source)) (P.fromAbs source))
-- |Checks if the given file exists and is not a directory. This follows -- |Checks if the given file exists and is not a directory.
-- symlinks, but will return True if the symlink is broken. -- Does not follow symlinks.
doesFileExist :: Path Abs -> IO Bool doesFileExist :: Path Abs -> IO Bool
doesFileExist fp = doesFileExist fp =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fp' <- fmap P.fromAbs $ P.canonicalizePath fp fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
fs <- PF.getFileStatus fp'
return $ not . PF.isDirectory $ fs return $ not . PF.isDirectory $ fs
-- |Checks if the given file exists and is a directory. This follows -- |Checks if the given file exists and is a directory.
-- symlinks, but will return False if the symlink is broken. -- Does not follow symlinks.
doesDirectoryExist :: Path Abs -> IO Bool doesDirectoryExist :: Path Abs -> IO Bool
doesDirectoryExist fp = doesDirectoryExist fp =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fp' <- fmap P.fromAbs $ P.canonicalizePath fp fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
fs <- PF.getFileStatus fp'
return $ PF.isDirectory fs return $ PF.isDirectory fs
-- |Checks whether a file or folder is writable.
isWritable :: Path Abs -> IO Bool
isWritable fp =
handleIOError (\_ -> return False) $
fileAccess (P.fromAbs fp) False True False
-- |Checks whether the directory at the given path exists and can be -- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream`. -- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path Abs -> IO Bool canOpenDirectory :: Path Abs -> IO Bool
canOpenDirectory fp = canOpenDirectory fp =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
@@ -249,3 +297,43 @@ rethrowErrnoAs en fmex action = catchErrno en action (throw fmex)
handleIOError :: (IOError -> IO a) -> IO a -> IO a handleIOError :: (IOError -> IO a) -> IO a -> IO a
handleIOError = flip catchIOError handleIOError = flip catchIOError
-- |Like `bracket`, but allows to have different clean-up
-- actions depending on whether the in-between computation
-- has raised an exception or not.
bracketeer :: IO a -- ^ computation to run first
-> (a -> IO b) -- ^ computation to run last, when
-- no exception was raised
-> (a -> IO b) -- ^ computation to run last,
-- when an exception was raised
-> (a -> IO c) -- ^ computation to run in-between
-> IO c
bracketeer before after afterEx thing =
mask $ \restore -> do
a <- before
r <- restore (thing a) `onException` afterEx a
_ <- after a
return r
reactOnError :: IO a
-> [(IOErrorType, IO a)] -- ^ reaction on IO errors
-> [(FmIOException, IO a)] -- ^ reaction on FmIOException
-> IO a
reactOnError a ios fmios =
a `catches` [iohandler, fmiohandler]
where
iohandler = Handler $
\(ex :: IOException) ->
foldr (\(t, a') y -> if ioeGetErrorType ex == t
then a'
else y)
(throwIO ex)
ios
fmiohandler = Handler $
\(ex :: FmIOException) ->
foldr (\(t, a') y -> if toConstr ex == toConstr t
then a'
else y)
(throwIO ex)
fmios

File diff suppressed because it is too large Load Diff

View File

@@ -18,39 +18,44 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides data types for representing directories/files
-- and related operations on it, mostly internal stuff. -- |This module provides a data type for representing directories/files
-- in a well-typed and convenient way. This is useful to gather and
-- save information about a file, so the information can be easily
-- processed in e.g. a GUI.
-- --
-- It doesn't allow to represent the whole filesystem, since that's only -- However, it's not meant to be used to interact with low-level
-- possible through IO laziness, which introduces too much internal state. -- functions that copy files etc, since there's no guarantee that
-- the in-memory representation of the type still matches what is
-- happening on filesystem level.
--
-- If you interact with low-level libraries, you must not pattern
-- match on the `File a` type. Instead, you should only use the saved
-- `path` and make no assumptions about the file the path might or
-- might not point to.
module HSFM.FileSystem.FileType where module HSFM.FileSystem.FileType where
import Data.ByteString(ByteString) import Data.ByteString(ByteString)
import Data.Default import Data.Default
import Data.Maybe
(
catMaybes
)
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
( (
POSIXTime POSIXTime
, posixSecondsToUTCTime , posixSecondsToUTCTime
) )
import Data.Time() import Data.Time()
import Foreign.C.Error
(
eACCES
)
import HPath import HPath
( (
Abs Abs
, Path , Path
, Fn
) )
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
(
getDirsFiles
)
import HSFM.Utils.MyPrelude import HSFM.Utils.MyPrelude
import Prelude hiding(readFile) import Prelude hiding(readFile)
import System.IO.Error import System.IO.Error
@@ -64,8 +69,7 @@ import System.Posix.FilePath
) )
import System.Posix.Directory.Traversals import System.Posix.Directory.Traversals
( (
getDirectoryContents realpath
, realpath
) )
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
import System.Posix.Types import System.Posix.Types
@@ -93,62 +97,61 @@ import System.Posix.Types
-- |The String in the path field is always a full path. -- |The String in the path field is always a full path.
-- The free type variable is used in the File/Dir constructor and can hold -- The free type variable is used in the File/Dir constructor and can hold
-- Handles, Strings representing a file's contents or anything else you can -- Handles, Strings representing a file's contents or anything else you can
-- think of. We catch any IO errors in the Failed constructor. an Exception -- think of. We catch any IO errors in the Failed constructor.
-- can be converted to a String with 'show'.
data File a = data File a =
Failed { Failed {
path :: Path Abs path :: !(Path Abs)
, err :: IOError , err :: IOError
} }
| Dir { | Dir {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
| RegFile { | RegFile {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
| SymLink { | SymLink {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
, sdest :: File a -- ^ symlink madness, , sdest :: File a -- ^ symlink madness,
-- we need to know where it points to -- we need to know where it points to
, rawdest :: ByteString , rawdest :: !ByteString
} }
| BlockDev { | BlockDev {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
| CharDev { | CharDev {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
| NamedPipe { | NamedPipe {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} }
| Socket { | Socket {
path :: Path Abs path :: !(Path Abs)
, fvar :: a , fvar :: a
} deriving (Show, Eq) } deriving (Show, Eq)
-- |Low-level file information. -- |Low-level file information.
data FileInfo = FileInfo { data FileInfo = FileInfo {
deviceID :: DeviceID deviceID :: !DeviceID
, fileID :: FileID , fileID :: !FileID
, fileMode :: FileMode , fileMode :: !FileMode
, linkCount :: LinkCount , linkCount :: !LinkCount
, fileOwner :: UserID , fileOwner :: !UserID
, fileGroup :: GroupID , fileGroup :: !GroupID
, specialDeviceID :: DeviceID , specialDeviceID :: !DeviceID
, fileSize :: FileOffset , fileSize :: !FileOffset
, accessTime :: EpochTime , accessTime :: !EpochTime
, modificationTime :: EpochTime , modificationTime :: !EpochTime
, statusChangeTime :: EpochTime , statusChangeTime :: !EpochTime
, accessTimeHiRes :: POSIXTime , accessTimeHiRes :: !POSIXTime
, modificationTimeHiRes :: POSIXTime , modificationTimeHiRes :: !POSIXTime
, statusChangeTimeHiRes :: POSIXTime , statusChangeTimeHiRes :: !POSIXTime
} deriving (Show, Eq, Ord) } deriving (Show, Eq, Ord)
@@ -461,19 +464,7 @@ isSocketC _ = False
---- IO HELPERS: ---- ---- IO HELPERS: ----
-- |Gets all filenames of the given directory. This excludes "." and "..".
getDirsFiles :: Path Abs -- ^ dir to read
-> IO [Path Abs]
getDirsFiles p =
P.withAbsPath p $ \fp ->
rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp)
$ return
. catMaybes
. fmap (\x -> (P.</>) p <$> (parseMaybe . snd $ x))
=<< getDirectoryContents fp
where
parseMaybe :: ByteString -> Maybe (Path Fn)
parseMaybe = P.parseFn
-- |Gets all file information. -- |Gets all file information.
@@ -563,9 +554,17 @@ getFreeVar _ = Nothing
-- |Pack the modification time into a string. -- |Pack the modification time into a string.
packModTime :: File FileInfo packModTime :: File FileInfo
-> String -> String
packModTime = packModTime = fromFreeVar $ epochToString . modificationTime
fromFreeVar
$ show . posixSecondsToUTCTime . realToFrac . modificationTime
-- |Pack the modification time into a string.
packAccessTime :: File FileInfo
-> String
packAccessTime = fromFreeVar $ epochToString . accessTime
epochToString :: EpochTime -> String
epochToString = show . posixSecondsToUTCTime . realToFrac
-- |Pack the permissions into a string, similar to what "ls -l" does. -- |Pack the permissions into a string, similar to what "ls -l" does.
@@ -599,3 +598,21 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
| otherwise = "-" | otherwise = "-"
hasFM fm = ffm `PF.intersectFileModes` fm == fm hasFM fm = ffm `PF.intersectFileModes` fm == fm
packFileType :: File a -> String
packFileType file = case file of
Dir {} -> "Directory"
RegFile {} -> "Regular File"
SymLink {} -> "Symbolic Link"
BlockDev {} -> "Block Device"
CharDev {} -> "Char Device"
NamedPipe {} -> "Named Pipe"
Socket {} -> "Socket"
_ -> "Unknown"
packLinkDestination :: File a -> Maybe ByteString
packLinkDestination file = case file of
SymLink { rawdest = dest } -> Just dest
_ -> Nothing

View File

@@ -0,0 +1,84 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides high-level IO related file operations like
-- copy, delete, move and so on. It only operates on `Path Abs` which
-- guarantees us well-typed paths which are absolute.
--
-- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling
-- and some implement functionality that doesn't have a unix
-- counterpart (like `copyDirRecursive`).
--
-- Some of these operations are due to their nature not _atomic_, which
-- means they may do multiple syscalls which form one context. Some
-- of them also have to examine the filetypes explicitly before the
-- syscalls, so a reasonable decision can be made. That means
-- the result is undefined if another process changes that context
-- while the non-atomic operation is still happening. However, where
-- possible, as few syscalls as possible are used and the underlying
-- exception handling is kept.
module HSFM.FileSystem.UtilTypes where
import Data.ByteString
(
ByteString
)
import HPath
(
Path
, Abs
, Fn
)
-- |Data type describing file operations.
-- Useful to build up a list of operations or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete [Path Abs]
| FOpen (Path Abs)
| FExecute (Path Abs) [ByteString]
| None
-- |Data type describing partial or complete file copy operation.
data Copy = PartialCopy [Path Abs] -- source files
| Copy [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Data type describing partial or complete file move operation.
data Move = PartialMove [Path Abs] -- source files
| Move [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Collision modes that describe the behavior in case a file collision
-- happens.
data FCollisonMode = Strict -- ^ fail if the target already exists
| Overwrite
| OverwriteAll
| Skip
| Rename (Path Fn)

View File

@@ -29,6 +29,7 @@ import Data.Maybe
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HSFM.GUI.Gtk.Callbacks
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.MyGUI import HSFM.GUI.Gtk.MyGUI
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
@@ -44,14 +45,13 @@ main = do
_ <- initGUI _ <- initGUI
args <- SPE.getArgs args <- SPE.getArgs
mygui <- createMyGUI
myview <- createMyView mygui createTreeView
let mdir = fromMaybe (fromJust $ P.parseAbs "/") let mdir = fromMaybe (fromJust $ P.parseAbs "/")
(P.parseAbs . headDef "/" $ args) (P.parseAbs . headDef "/" $ args)
refreshView mygui myview (Just $ mdir)
mygui <- createMyGUI
_ <- newTab mygui createTreeView mdir
setGUICallbacks mygui
widgetShowAll (rootWin mygui) widgetShowAll (rootWin mygui)

View File

@@ -32,13 +32,18 @@ import Control.Exception
) )
import Control.Monad import Control.Monad
( (
void forM_
, forM_ , void
, when
) )
import Control.Monad.IO.Class import Control.Monad.IO.Class
( (
liftIO liftIO
) )
import Data.ByteString
(
ByteString
)
import Data.Foldable import Data.Foldable
( (
for_ for_
@@ -53,6 +58,8 @@ import HPath
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Callbacks.Utils
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView import HSFM.GUI.Gtk.MyView
@@ -67,6 +74,12 @@ import System.Posix.Env.ByteString
( (
getEnv getEnv
) )
import qualified System.Posix.Process.ByteString as SPP
import System.Posix.Types
(
ProcessID
)
@@ -76,14 +89,75 @@ import System.Posix.Env.ByteString
----------------- -----------------
-- |Set callbacks, on hotkeys, events and stuff.
setCallbacks :: MyGUI -> MyView -> IO ()
setCallbacks mygui myview = do ---- MAIN CALLBACK ENTRYPOINT ----
-- |Set callbacks for the whole gui, on hotkeys, events and stuff.
setGUICallbacks :: MyGUI -> IO ()
setGUICallbacks mygui = do
_ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui
writeTVarIO (operationBuffer mygui) None
-- menubar-file
_ <- (menubarFileQuit . menubar) mygui `on` menuItemActivated $
mainQuit
-- menubar-help
_ <- (menubarHelpAbout . menubar) mygui `on` menuItemActivated $
liftIO showAboutDialog
return ()
-- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
return ()
-- |Set callbacks specific to a given view, on hotkeys, events and stuff.
setViewCallbacks :: MyGUI -> MyView -> IO ()
setViewCallbacks mygui myview = do
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
case view' of case view' of
fmv@(FMTreeView treeView) -> do fmv@(FMTreeView treeView) -> do
_ <- treeView `on` rowActivated _ <- treeView `on` rowActivated
$ (\_ _ -> withItems mygui myview open) $ (\_ _ -> withItems mygui myview open)
-- drag events
_ <- treeView `on` dragBegin $
\_ -> withItems mygui myview moveInit
_ <- treeView `on` dragDrop $
\dc p ts -> do
p' <- treeViewConvertWidgetToTreeCoords treeView p
mpath <- treeViewGetPathAtPos treeView p'
case mpath of
Nothing -> do
dragFinish dc False False ts
return False
Just _ -> do
atom <- atomNew ("HSFM" :: String)
dragGetData treeView dc atom ts
return True
_ <- treeView `on` dragDataReceived $
\dc p _ ts ->
liftIO $ do
signalStopEmission treeView "drag_data_received"
p' <- treeViewConvertWidgetToTreeCoords treeView p
mpath <- treeViewGetPathAtPos treeView p'
case mpath of
Nothing -> dragFinish dc False False ts
Just (tp, _, _) -> do
mitem <- rawPathToItem myview tp
forM_ mitem $ \item ->
operationFinal mygui myview (Just item)
dragFinish dc True False ts
commonGuiEvents fmv commonGuiEvents fmv
return () return ()
fmv@(FMIconView iconView) -> do fmv@(FMIconView iconView) -> do
@@ -91,73 +165,40 @@ setCallbacks mygui myview = do
$ (\_ -> withItems mygui myview open) $ (\_ -> withItems mygui myview open)
commonGuiEvents fmv commonGuiEvents fmv
return () return ()
menubarCallbacks
where where
menubarCallbacks = do
-- menubar-file
_ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
_ <- menubarFileOpen mygui `on` menuItemActivated $
liftIO $ withItems mygui myview open
_ <- menubarFileExecute mygui `on` menuItemActivated $
liftIO $ withItems mygui myview execute
_ <- menubarFileNew mygui `on` menuItemActivated $
liftIO $ newFile mygui myview
-- menubar-edit
_ <- menubarEditCut mygui `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit
_ <- menubarEditCopy mygui `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit
_ <- menubarEditRename mygui `on` menuItemActivated $
liftIO $ withItems mygui myview renameF
_ <- menubarEditPaste mygui `on` menuItemActivated $
liftIO $ operationFinal mygui myview
_ <- menubarEditDelete mygui `on` menuItemActivated $
liftIO $ withItems mygui myview del
-- mewnubar-view
_ <- menubarViewIcon mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- menubarViewTree mygui `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
-- menubar-help
_ <- menubarHelpAbout mygui `on` menuItemActivated $
liftIO showAboutDialog
return ()
commonGuiEvents fmv = do commonGuiEvents fmv = do
let view = fmViewToContainer fmv let view = fmViewToContainer fmv
-- GUI events -- GUI events
_ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview _ <- urlBar myview `on` entryActivated $ urlGoTo mygui myview
_ <- upViewB myview `on` buttonActivated $
_ <- upViewB mygui `on` buttonActivated $
upDir mygui myview upDir mygui myview
_ <- homeViewB mygui `on` buttonActivated $ _ <- homeViewB myview `on` buttonActivated $
goHome mygui myview goHome mygui myview
_ <- refreshViewB mygui `on` buttonActivated $ do _ <- refreshViewB myview `on` buttonActivated $ do
cdir <- liftIO $ getCurrentDir myview cdir <- liftIO $ getCurrentDir myview
refreshView' mygui myview cdir refreshView' mygui myview cdir
_ <- clearStatusBar mygui `on` buttonActivated $ do
popStatusbar mygui
writeTVarIO (operationBuffer myview) None
-- key events -- key events
_ <- rootWin mygui `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"q" <- fmap glibToString eventKeyName
liftIO mainQuit
_ <- view `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"h" <- fmap glibToString eventKeyName "h" <- fmap glibToString eventKeyName
cdir <- liftIO $ getCurrentDir myview cdir <- liftIO $ getCurrentDir myview
liftIO $ modifyTVarIO (settings mygui) liftIO $ modifyTVarIO (settings mygui)
(\x -> x { showHidden = not . showHidden $ x}) (\x -> x { showHidden = not . showHidden $ x})
>> refreshView' mygui myview cdir >> refreshView' mygui myview cdir
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier [Alt] <- eventModifier
"Up" <- fmap glibToString eventKeyName "Up" <- fmap glibToString eventKeyName
liftIO $ upDir mygui myview liftIO $ upDir mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Left" <- fmap glibToString eventKeyName
liftIO $ goHistoryPrev mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Alt] <- eventModifier
"Right" <- fmap glibToString eventKeyName
liftIO $ goHistoryNext mygui myview
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- view `on` keyPressEvent $ tryEvent $ do
"Delete" <- fmap glibToString eventKeyName "Delete" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview del liftIO $ withItems mygui myview del
@@ -173,10 +214,23 @@ setCallbacks mygui myview = do
[Control] <- eventModifier [Control] <- eventModifier
"x" <- fmap glibToString eventKeyName "x" <- fmap glibToString eventKeyName
liftIO $ withItems mygui myview moveInit liftIO $ withItems mygui myview moveInit
_ <- view `on` keyPressEvent $ tryEvent $ do _ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier [Control] <- eventModifier
"v" <- fmap glibToString eventKeyName "v" <- fmap glibToString eventKeyName
liftIO $ operationFinal mygui myview liftIO $ operationFinal mygui myview Nothing
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"t" <- fmap glibToString eventKeyName
liftIO $ void $ do
cwd <- getCurrentDir myview
newTab mygui createTreeView (path cwd)
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
[Control] <- eventModifier
"w" <- fmap glibToString eventKeyName
liftIO $ void $ closeTab mygui myview
_ <- viewBox myview `on` keyPressEvent $ tryEvent $ do
"F4" <- fmap glibToString eventKeyName
liftIO $ void $ openTerminalHere myview
-- righ-click -- righ-click
_ <- view `on` buttonPressEvent $ do _ <- view `on` buttonPressEvent $ do
@@ -184,7 +238,7 @@ setCallbacks mygui myview = do
t <- eventTime t <- eventTime
case eb of case eb of
RightButton -> do RightButton -> do
_ <- liftIO $ menuPopup (rcMenu mygui) _ <- liftIO $ menuPopup (rcMenu . rcmenu $ myview)
$ Just (RightButton, t) $ Just (RightButton, t)
-- this is just to not screw with current selection -- this is just to not screw with current selection
-- on right-click -- on right-click
@@ -200,25 +254,42 @@ setCallbacks mygui myview = do
return $ elem tp selectedTps return $ elem tp selectedTps
-- no item under the cursor, pass on the signal -- no item under the cursor, pass on the signal
Nothing -> return False Nothing -> return False
OtherButton 8 -> do
liftIO $ goHistoryPrev mygui myview
return False
OtherButton 9 -> do
liftIO $ goHistoryNext mygui myview
return False
-- not right-click, so pass on the signal -- not right-click, so pass on the signal
_ -> return False _ -> return False
_ <- rcFileOpen mygui `on` menuItemActivated $
-- right click menu
_ <- (rcFileOpen . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview open liftIO $ withItems mygui myview open
_ <- rcFileExecute mygui `on` menuItemActivated $ _ <- (rcFileExecute . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview execute liftIO $ withItems mygui myview execute
_ <- rcFileNew mygui `on` menuItemActivated $ _ <- (rcFileNewRegFile . rcmenu) myview `on` menuItemActivated $
liftIO $ newFile mygui myview liftIO $ newFile mygui myview
_ <- rcFileCopy mygui `on` menuItemActivated $ _ <- (rcFileNewDir . rcmenu) myview `on` menuItemActivated $
liftIO $ newDir mygui myview
_ <- (rcFileCopy . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview copyInit liftIO $ withItems mygui myview copyInit
_ <- rcFileRename mygui `on` menuItemActivated $ _ <- (rcFileRename . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview renameF liftIO $ withItems mygui myview renameF
_ <- rcFilePaste mygui `on` menuItemActivated $ _ <- (rcFilePaste . rcmenu) myview `on` menuItemActivated $
liftIO $ operationFinal mygui myview liftIO $ operationFinal mygui myview Nothing
_ <- rcFileDelete mygui `on` menuItemActivated $ _ <- (rcFileDelete . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview del liftIO $ withItems mygui myview del
_ <- rcFileCut mygui `on` menuItemActivated $ _ <- (rcFileProperty . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview showFilePropertyDialog
_ <- (rcFileCut . rcmenu) myview `on` menuItemActivated $
liftIO $ withItems mygui myview moveInit liftIO $ withItems mygui myview moveInit
_ <- (rcFileIconView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createIconView
_ <- (rcFileTreeView . rcmenu) myview `on` menuItemActivated $
liftIO $ switchView mygui myview createTreeView
return () return ()
getPathAtPos fmv (x, y) = getPathAtPos fmv (x, y) =
case fmv of case fmv of
FMTreeView treeView -> do FMTreeView treeView -> do
@@ -230,47 +301,31 @@ setCallbacks mygui myview = do
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView. ---- OTHER ----
--
-- If the url is invalid, does nothing.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar mygui)
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
refreshView mygui myview (Just fp')
goHome :: MyGUI -> MyView -> IO () openTerminalHere :: MyView -> IO ProcessID
goHome mygui myview = withErrorDialog $ do openTerminalHere myview = do
mhomedir <- getEnv "HOME" cwd <- (P.fromAbs . path) <$> getCurrentDir myview
refreshView mygui myview (P.parseAbs =<< mhomedir) -- TODO: make terminal configurable
SPP.forkProcess $ SPP.executeFile "sakura" True ["-d", cwd] Nothing
-- |Supposed to be used with 'withRows'. Opens a file or directory.
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ path r
refreshView' mygui myview nv
r ->
void $ openFile r
-- this throws on the first error that occurs
open (FileLikeList fs) _ _ = withErrorDialog $
forM_ fs $ \f -> void $ openFile f
open _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Execute a given file. ---- TAB OPERATIONS ----
execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $
void $ executeFile item [] -- |Closes the current tab, but only if there is more than one tab.
execute _ _ _ = withErrorDialog closeTab :: MyGUI -> MyView -> IO ()
. throw $ InvalidOperation closeTab mygui myview = do
"Operation not supported on multiple files" n <- notebookGetNPages (notebook mygui)
when (n > 1) $ void $ destroyView mygui myview
---- FILE OPERATION CALLBACKS (COPY, MOVE, ...) ----
-- |Supposed to be used with 'withRows'. Deletes a file or directory. -- |Supposed to be used with 'withRows'. Deletes a file or directory.
@@ -278,12 +333,12 @@ del :: [Item] -> MyGUI -> MyView -> IO ()
del [item] _ _ = withErrorDialog $ do del [item] _ _ = withErrorDialog $ do
let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?" let cmsg = "Really delete \"" ++ getFPasStr item ++ "\"?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ easyDelete item $ easyDelete . path $ item
-- this throws on the first error that occurs -- this throws on the first error that occurs
del items@(_:_) _ _ = withErrorDialog $ do del items@(_:_) _ _ = withErrorDialog $ do
let cmsg = "Really delete " ++ show (length items) ++ " files?" let cmsg = "Really delete " ++ show (length items) ++ " files?"
withConfirmationDialog cmsg withConfirmationDialog cmsg
$ forM_ items $ \item -> easyDelete item $ forM_ items $ \item -> easyDelete . path $ item
del _ _ _ = withErrorDialog del _ _ _ = withErrorDialog
. throw $ InvalidOperation . throw $ InvalidOperation
"Operation not supported on multiple files" "Operation not supported on multiple files"
@@ -291,8 +346,8 @@ del _ _ _ = withErrorDialog
-- |Initializes a file move operation. -- |Initializes a file move operation.
moveInit :: [Item] -> MyGUI -> MyView -> IO () moveInit :: [Item] -> MyGUI -> MyView -> IO ()
moveInit items@(_:_) mygui myview = do moveInit items@(_:_) mygui _ = do
writeTVarIO (operationBuffer myview) (FMove . MP1 . map path $ items) writeTVarIO (operationBuffer mygui) (FMove . PartialMove . map path $ items)
let sbmsg = case items of let sbmsg = case items of
(item:[]) -> "Move buffer: " ++ getFPasStr item (item:[]) -> "Move buffer: " ++ getFPasStr item
_ -> "Move buffer: " ++ (show . length $ items) _ -> "Move buffer: " ++ (show . length $ items)
@@ -305,8 +360,8 @@ moveInit _ _ _ = withErrorDialog
-- |Supposed to be used with 'withRows'. Initializes a file copy operation. -- |Supposed to be used with 'withRows'. Initializes a file copy operation.
copyInit :: [Item] -> MyGUI -> MyView -> IO () copyInit :: [Item] -> MyGUI -> MyView -> IO ()
copyInit items@(_:_) mygui myview = do copyInit items@(_:_) mygui _ = do
writeTVarIO (operationBuffer myview) (FCopy . CP1 . map path $ items) writeTVarIO (operationBuffer mygui) (FCopy . PartialCopy . map path $ items)
let sbmsg = case items of let sbmsg = case items of
(item:[]) -> "Copy buffer: " ++ getFPasStr item (item:[]) -> "Copy buffer: " ++ getFPasStr item
_ -> "Copy buffer: " ++ (show . length $ items) _ -> "Copy buffer: " ++ (show . length $ items)
@@ -319,25 +374,25 @@ copyInit _ _ _ = withErrorDialog
-- |Finalizes a file operation, such as copy or move. -- |Finalizes a file operation, such as copy or move.
operationFinal :: MyGUI -> MyView -> IO () operationFinal :: MyGUI -> MyView -> Maybe Item -> IO ()
operationFinal _ myview = withErrorDialog $ do operationFinal mygui myview mitem = withErrorDialog $ do
op <- readTVarIO (operationBuffer myview) op <- readTVarIO (operationBuffer mygui)
cdir <- path <$> getCurrentDir myview cdir <- case mitem of
Nothing -> path <$> getCurrentDir myview
Just x -> return $ path x
case op of case op of
FMove (MP1 s) -> do FMove (PartialMove s) -> do
let cmsg = "Really move " ++ imsg s let cmsg = "Really move " ++ imsg s
++ " to \"" ++ P.fpToString (P.fromAbs cdir) ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
++ "\"?" ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
$ \cm -> void $ runFileOp (FMove . MC s cdir $ cm) popStatusbar mygui
return () writeTVarIO (operationBuffer mygui) None
FCopy (CP1 s) -> do FCopy (PartialCopy s) -> do
let cmsg = "Really copy " ++ imsg s let cmsg = "Really copy " ++ imsg s
++ " to \"" ++ P.fpToString (P.fromAbs cdir) ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
++ "\"?" ++ "\"?"
withConfirmationDialog cmsg . withCopyModeDialog withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
$ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
return ()
_ -> return () _ -> return ()
where where
imsg s = case s of imsg s = case s of
@@ -345,27 +400,30 @@ operationFinal _ myview = withErrorDialog $ do
items -> (show . length $ items) ++ " items" items -> (show . length $ items) ++ " items"
-- |Go up one directory and visualize it in the treeView. -- |Create a new file.
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
nv <- goUp cdir
refreshView' mygui myview nv
-- |Go up one directory and visualize it in the treeView.
newFile :: MyGUI -> MyView -> IO () newFile :: MyGUI -> MyView -> IO ()
newFile _ myview = withErrorDialog $ do newFile _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter file name" mfn <- textInputDialog "Enter file name" ("" :: String)
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview cdir <- getCurrentDir myview
createFile cdir fn createRegularFile (path cdir P.</> fn)
-- |Create a new directory.
newDir :: MyGUI -> MyView -> IO ()
newDir _ myview = withErrorDialog $ do
mfn <- textInputDialog "Enter directory name" ("" :: String)
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do
cdir <- getCurrentDir myview
createDir (path cdir P.</> fn)
renameF :: [Item] -> MyGUI -> MyView -> IO () renameF :: [Item] -> MyGUI -> MyView -> IO ()
renameF [item] _ _ = withErrorDialog $ do renameF [item] _ _ = withErrorDialog $ do
mfn <- textInputDialog "Enter new file name" iname <- P.fromRel <$> (P.basename $ path item)
mfn <- textInputDialog "Enter new file name" (iname :: ByteString)
let pmfn = P.parseFn =<< P.userStringToFP <$> mfn let pmfn = P.parseFn =<< P.userStringToFP <$> mfn
for_ pmfn $ \fn -> do for_ pmfn $ \fn -> do
let cmsg = "Really rename \"" ++ getFPasStr item let cmsg = "Really rename \"" ++ getFPasStr item
@@ -373,7 +431,96 @@ renameF [item] _ _ = withErrorDialog $ do
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item) ++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?" P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $ withConfirmationDialog cmsg $
HSFM.FileSystem.FileOperations.renameFile item fn HSFM.FileSystem.FileOperations.renameFile (path item)
((P.dirname $ path item) P.</> fn)
renameF _ _ _ = withErrorDialog renameF _ _ _ = withErrorDialog
. throw $ InvalidOperation . throw $ InvalidOperation
"Operation not supported on multiple files" "Operation not supported on multiple files"
---- DIRECTORY TRAVERSAL AND FILE OPENING CALLBACKS ----
-- |Go to the url given at the 'urlBar' and visualize it in the given
-- treeView.
--
-- If the url is invalid, does nothing.
urlGoTo :: MyGUI -> MyView -> IO ()
urlGoTo mygui myview = withErrorDialog $ do
fp <- entryGetText (urlBar myview)
forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
goHome :: MyGUI -> MyView -> IO ()
goHome mygui myview = withErrorDialog $ do
mhomedir <- getEnv "HOME"
forM_ (P.parseAbs =<< mhomedir :: Maybe (Path Abs)) $ \fp' ->
whenM (canOpenDirectory fp')
(goDir mygui myview =<< (readFile getFileInfo $ fp'))
-- |Execute a given file.
execute :: [Item] -> MyGUI -> MyView -> IO ()
execute [item] _ _ = withErrorDialog $
void $ executeFile (path item) []
execute _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Supposed to be used with 'withRows'. Opens a file or directory.
open :: [Item] -> MyGUI -> MyView -> IO ()
open [item] mygui myview = withErrorDialog $
case item of
DirOrSym r -> do
nv <- readFile getFileInfo $ path r
goDir mygui myview nv
r ->
void $ openFile . path $ r
-- this throws on the first error that occurs
open (FileLikeList fs) _ _ = withErrorDialog $
forM_ fs $ \f -> void $ openFile . path $ f
open _ _ _ = withErrorDialog
. throw $ InvalidOperation
"Operation not supported on multiple files"
-- |Go up one directory and visualize it in the treeView.
upDir :: MyGUI -> MyView -> IO ()
upDir mygui myview = withErrorDialog $ do
cdir <- getCurrentDir myview
nv <- goUp cdir
goDir mygui myview nv
-- |Go "back" in the history.
goHistoryPrev :: MyGUI -> MyView -> IO ()
goHistoryPrev mygui myview = do
hs <- readTVarIO (history myview)
case hs of
([], _) -> return ()
(x:xs, _) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(_, n) -> (xs, path cdir `addHistory` n))
refreshView' mygui myview nv
-- |Go "forth" in the history.
goHistoryNext :: MyGUI -> MyView -> IO ()
goHistoryNext mygui myview = do
hs <- readTVarIO (history myview)
case hs of
(_, []) -> return ()
(_, x:xs) -> do
cdir <- getCurrentDir myview
nv <- readFile getFileInfo $ x
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, xs))
refreshView' mygui myview nv

View File

@@ -22,4 +22,4 @@ module HSFM.GUI.Gtk.Callbacks where
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
setCallbacks :: MyGUI -> MyView -> IO () setViewCallbacks :: MyGUI -> MyView -> IO ()

View File

@@ -0,0 +1,102 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2016 Julian Ospald
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
version 2 as published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.Callbacks.Utils where
import Control.Monad
(
forM_
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Dialogs
import HSFM.GUI.Gtk.MyView
import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO
(
modifyTVarIO
)
import Prelude hiding(readFile)
-- |Carries out a file operation with the appropriate error handling
-- allowing the user to react to various exceptions with further input.
doFileOperation :: FileOperation -> IO ()
doFileOperation (FCopy (Copy (f':fs') to)) =
_doFileOperation (f':fs') to easyCopyOverwrite easyCopy
$ doFileOperation (FCopy $ Copy fs' to)
doFileOperation (FMove (Move (f':fs') to)) =
_doFileOperation (f':fs') to moveFileOverwrite moveFile
$ doFileOperation (FMove $ Move fs' to)
where
doFileOperation _ = return ()
_doFileOperation :: [P.Path b1]
-> P.Path P.Abs
-> (P.Path b1 -> P.Path P.Abs -> IO b)
-> (P.Path b1 -> P.Path P.Abs -> IO a)
-> IO ()
-> IO ()
_doFileOperation [] _ _ _ _ = return ()
_doFileOperation (f:fs) to mcOverwrite mc rest = do
toname <- P.basename f
let topath = to P.</> toname
reactOnError (mc f topath >> rest)
[(AlreadyExists , collisionAction fileCollisionDialog topath)]
[(FileDoesExist{}, collisionAction fileCollisionDialog topath)
,(DirDoesExist{} , collisionAction fileCollisionDialog topath)
,(SameFile{} , collisionAction renameDialog topath)]
where
collisionAction diag topath = do
mcm <- diag . P.fromAbs $ topath
forM_ mcm $ \cm -> case cm of
Overwrite -> mcOverwrite f topath >> rest
OverwriteAll -> forM_ (f:fs) $ \x -> do
toname' <- P.basename x
mcOverwrite x (to P.</> toname')
Skip -> rest
Rename newn -> mc f (to P.</> newn) >> rest
_ -> return ()
-- |Helper that is invoked for any directory change operations.
goDir :: MyGUI -> MyView -> Item -> IO ()
goDir mygui myview item = do
cdir <- getCurrentDir myview
modifyTVarIO (history myview)
(\(p, _) -> (path cdir `addHistory` p, []))
refreshView' mygui myview item

View File

@@ -29,10 +29,15 @@ import Control.Concurrent.STM
( (
TVar TVar
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk hiding (MenuBar)
import HSFM.FileSystem.FileOperations import HPath
(
Abs
, Path
)
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import System.INotify.ByteString import HSFM.FileSystem.UtilTypes
import System.INotify
( (
INotify INotify
) )
@@ -50,65 +55,96 @@ import System.INotify.ByteString
-- runtime. -- runtime.
data MyGUI = MkMyGUI { data MyGUI = MkMyGUI {
-- |main Window -- |main Window
rootWin :: Window rootWin :: !Window
, menubarFileQuit :: ImageMenuItem
, menubarFileOpen :: ImageMenuItem -- widgets on the main window
, menubarFileExecute :: ImageMenuItem , menubar :: !MenuBar
, menubarFileNew :: ImageMenuItem , statusBar :: !Statusbar
, menubarEditCut :: ImageMenuItem , clearStatusBar :: !Button
, menubarEditCopy :: ImageMenuItem , notebook :: !Notebook
, menubarEditRename :: ImageMenuItem
, menubarEditPaste :: ImageMenuItem -- other
, menubarEditDelete :: ImageMenuItem , fprop :: !FilePropertyGrid
, menubarViewTree :: ImageMenuItem , settings :: !(TVar FMSettings)
, menubarViewIcon :: ImageMenuItem
, menubarHelpAbout :: ImageMenuItem , operationBuffer :: !(TVar FileOperation)
, rcMenu :: Menu }
, rcFileOpen :: ImageMenuItem
, rcFileExecute :: ImageMenuItem
, rcFileNew :: ImageMenuItem -- |This describes the contents of the current view and is separated from MyGUI,
, rcFileCut :: ImageMenuItem -- because we might want to have multiple views.
, rcFileCopy :: ImageMenuItem data MyView = MkMyView {
, rcFileRename :: ImageMenuItem view :: !(TVar FMView)
, rcFilePaste :: ImageMenuItem , cwd :: !(MVar Item)
, rcFileDelete :: ImageMenuItem , rawModel :: !(TVar (ListStore Item))
, upViewB :: Button , sortedModel :: !(TVar (TypedTreeModelSort Item))
, homeViewB :: Button , filteredModel :: !(TVar (TypedTreeModelFilter Item))
, refreshViewB :: Button , inotify :: !(MVar INotify)
, urlBar :: Entry
, statusBar :: Statusbar -- the first part of the tuple represents the "go back"
, clearStatusBar :: Button -- the second part the "go forth" in the history
, settings :: TVar FMSettings , history :: !(TVar ([Path Abs], [Path Abs]))
, scroll :: ScrolledWindow
-- sub-widgets
, scroll :: !ScrolledWindow
, viewBox :: !Box
, rcmenu :: !RightClickMenu
, upViewB :: !Button
, homeViewB :: !Button
, refreshViewB :: !Button
, urlBar :: !Entry
}
data MenuBar = MkMenuBar {
menubarFileQuit :: !ImageMenuItem
, menubarHelpAbout :: !ImageMenuItem
}
data RightClickMenu = MkRightClickMenu {
rcMenu :: !Menu
, rcFileOpen :: !ImageMenuItem
, rcFileExecute :: !ImageMenuItem
, rcFileNewRegFile :: !ImageMenuItem
, rcFileNewDir :: !ImageMenuItem
, rcFileCut :: !ImageMenuItem
, rcFileCopy :: !ImageMenuItem
, rcFileRename :: !ImageMenuItem
, rcFilePaste :: !ImageMenuItem
, rcFileDelete :: !ImageMenuItem
, rcFileProperty :: !ImageMenuItem
, rcFileIconView :: !ImageMenuItem
, rcFileTreeView :: !ImageMenuItem
}
data FilePropertyGrid = MkFilePropertyGrid {
fpropGrid :: !Grid
, fpropFnEntry :: !Entry
, fpropLocEntry :: !Entry
, fpropTsEntry :: !Entry
, fpropModEntry :: !Entry
, fpropAcEntry :: !Entry
, fpropFTEntry :: !Entry
, fpropPermEntry :: !Entry
, fpropLDEntry :: !Entry
} }
-- |FM-wide settings. -- |FM-wide settings.
data FMSettings = MkFMSettings { data FMSettings = MkFMSettings {
showHidden :: Bool showHidden :: !Bool
, isLazy :: Bool , isLazy :: !Bool
, iconSize :: Int , iconSize :: !Int
} }
data FMView = FMTreeView TreeView data FMView = FMTreeView !TreeView
| FMIconView IconView | FMIconView !IconView
type Item = File FileInfo type Item = File FileInfo
-- |This describes the contents of the current vie and is separated from MyGUI,
-- because we might want to have multiple views.
data MyView = MkMyView {
view :: TVar FMView
, cwd :: MVar Item
, rawModel :: TVar (ListStore Item)
, sortedModel :: TVar (TypedTreeModelSort Item)
, filteredModel :: TVar (TypedTreeModelFilter Item)
, operationBuffer :: TVar FileOperation
, inotify :: MVar INotify
}
fmViewToContainer :: FMView -> Container fmViewToContainer :: FMView -> Container
fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x fmViewToContainer (FMTreeView x) = castToContainer . toGObject $ x
fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x fmViewToContainer (FMIconView x) = castToContainer . toGObject $ x

View File

@@ -23,8 +23,7 @@ module HSFM.GUI.Gtk.Dialogs where
import Control.Exception import Control.Exception
( (
catch displayException
, displayException
, throw , throw
, IOException , IOException
, catches , catches
@@ -36,6 +35,15 @@ import Control.Monad
, when , when
, void , void
) )
import Data.ByteString
(
ByteString
)
import qualified Data.ByteString as BS
import Data.ByteString.UTF8
(
fromString
)
import Data.Version import Data.Version
( (
showVersion showVersion
@@ -61,12 +69,27 @@ import Distribution.Verbosity
import Graphics.UI.Gtk import Graphics.UI.Gtk
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Errors import HSFM.GUI.Gtk.Errors
import Paths_hsfm import Paths_hsfm
( (
getDataFileName getDataFileName
) )
import System.Glib.UTFString
(
GlibString
)
import System.Posix.FilePath
(
takeFileName
)
@@ -104,83 +127,65 @@ showConfirmationDialog str = do
_ -> return False _ -> return False
-- |Asks the user which directory copy mode he wants via dialog popup fileCollisionDialog :: ByteString -> IO (Maybe FCollisonMode)
-- and returns 'DirCopyMode'. Default is always Strict, so this allows fileCollisionDialog t = do
-- switching to Merge/Replace/Rename.
showCopyModeDialog :: IO (Maybe CopyMode)
showCopyModeDialog = do
chooserDialog <- messageDialogNew Nothing chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent] [DialogDestroyWithParent]
MessageQuestion MessageQuestion
ButtonsNone ButtonsNone
"Target exists, how to proceed?" (fromString "Target \"" `BS.append`
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) t `BS.append`
_ <- dialogAddButton chooserDialog "Merge" (ResponseUser 1) fromString "\" exists, how to proceed?")
_ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2) _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 3) _ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1)
_ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 3)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 4)
rID <- dialogRun chooserDialog rID <- dialogRun chooserDialog
widgetDestroy chooserDialog widgetDestroy chooserDialog
case rID of case rID of
ResponseUser 0 -> return Nothing ResponseUser 0 -> return Nothing
ResponseUser 1 -> return (Just Merge) ResponseUser 1 -> return (Just Overwrite)
ResponseUser 2 -> return (Just Replace) ResponseUser 2 -> return (Just OverwriteAll)
ResponseUser 3 -> do ResponseUser 3 -> return (Just Skip)
mfn <- textInputDialog "Enter new name" ResponseUser 4 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do forM mfn $ \fn -> do
pfn <- P.parseFn (P.userStringToFP fn) pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn return $ Rename pfn
_ -> throw UnknownDialogButton _ -> throw UnknownDialogButton
-- |Stipped version of `showCopyModeDialog` that only allows cancelling renameDialog :: ByteString -> IO (Maybe FCollisonMode)
-- or Renaming. renameDialog t = do
showRenameDialog :: IO (Maybe CopyMode)
showRenameDialog = do
chooserDialog <- messageDialogNew Nothing chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent] [DialogDestroyWithParent]
MessageQuestion MessageQuestion
ButtonsNone ButtonsNone
"Target exists, how to proceed?" (fromString "Target \"" `BS.append`
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) t `BS.append`
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 1) fromString "\" exists, how to proceed?")
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Skip" (ResponseUser 1)
_ <- dialogAddButton chooserDialog "Rename" (ResponseUser 2)
rID <- dialogRun chooserDialog rID <- dialogRun chooserDialog
widgetDestroy chooserDialog widgetDestroy chooserDialog
case rID of case rID of
ResponseUser 0 -> return Nothing ResponseUser 0 -> return Nothing
ResponseUser 1 -> do ResponseUser 1 -> return (Just Skip)
mfn <- textInputDialog "Enter new name" ResponseUser 2 -> do
mfn <- textInputDialog (fromString "Enter new name") (takeFileName t)
forM mfn $ \fn -> do forM mfn $ \fn -> do
pfn <- P.parseFn (P.userStringToFP fn) pfn <- P.parseFn (P.userStringToFP fn)
return $ Rename pfn return $ Rename pfn
_ -> throw UnknownDialogButton _ -> throw UnknownDialogButton
-- |Attempts to run the given function with the `Strict` copy mode.
-- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
-- the user for action via `showCopyModeDialog` and then carries out
-- the given function again.
withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
withCopyModeDialog fa =
catch (fa Strict) $ \e ->
case e of
FileDoesExist _ -> doIt showCopyModeDialog
DirDoesExist _ -> doIt showCopyModeDialog
SameFile _ _ -> doIt showRenameDialog
e' -> throw e'
where
doIt getCm = do
mcm <- getCm
case mcm of
(Just Strict) -> return () -- don't try again
(Just cm) -> fa cm
Nothing -> return ()
-- |Shows the about dialog from the help menu. -- |Shows the about dialog from the help menu.
showAboutDialog :: IO () showAboutDialog :: IO ()
showAboutDialog = do showAboutDialog = do
ad <- aboutDialogNew ad <- aboutDialogNew
lstr <- readFile =<< getDataFileName "LICENSE" lstr <- Prelude.readFile =<< getDataFileName "LICENSE"
hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png" hsfmicon <- pixbufNewFromFile =<< getDataFileName "data/Gtk/icons/hsfm.png"
pdesc <- fmap packageDescription pdesc <- fmap packageDescription
(readPackageDescription silent (readPackageDescription silent
@@ -223,14 +228,18 @@ withErrorDialog io =
-- |Asks the user which directory copy mode he wants via dialog popup -- |Asks the user which directory copy mode he wants via dialog popup
-- and returns 'DirCopyMode'. -- and returns 'DirCopyMode'.
textInputDialog :: String -> IO (Maybe String) textInputDialog :: GlibString string
textInputDialog title = do => string -- ^ window title
-> string -- ^ initial text in input widget
-> IO (Maybe String)
textInputDialog title inittext = do
chooserDialog <- messageDialogNew Nothing chooserDialog <- messageDialogNew Nothing
[DialogDestroyWithParent] [DialogDestroyWithParent]
MessageQuestion MessageQuestion
ButtonsNone ButtonsNone
title title
entry <- entryNew entry <- entryNew
entrySetText entry inittext
cbox <- dialogGetActionArea chooserDialog cbox <- dialogGetActionArea chooserDialog
_ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0) _ <- dialogAddButton chooserDialog "Ok" (ResponseUser 0)
_ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1) _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 1)
@@ -244,3 +253,50 @@ textInputDialog title = do
_ -> throw UnknownDialogButton _ -> throw UnknownDialogButton
widgetDestroy chooserDialog widgetDestroy chooserDialog
return ret return ret
showFilePropertyDialog :: [Item] -> MyGUI -> MyView -> IO ()
showFilePropertyDialog [item] mygui _ = do
dialog <- messageDialogNew Nothing
[DialogDestroyWithParent]
MessageInfo
ButtonsNone
"File Properties"
let fprop' = fprop mygui
grid = fpropGrid fprop'
entrySetText (fpropFnEntry fprop') (maybe BS.empty P.fromRel
$ P.basename . path $ item)
entrySetText (fpropLocEntry fprop') (P.fromAbs . P.dirname . path $ item)
entrySetText (fpropTsEntry fprop') (fromFreeVar (show . fileSize) item)
entrySetText (fpropModEntry fprop') (packModTime item)
entrySetText (fpropAcEntry fprop') (packAccessTime item)
entrySetText (fpropFTEntry fprop') (packFileType item)
entrySetText (fpropPermEntry fprop')
(tail $ packPermissions item) -- throw away the filetype part
case packLinkDestination item of
(Just dest) -> do
widgetSetSensitive (fpropLDEntry fprop') True
entrySetText (fpropLDEntry fprop') dest
Nothing -> do
widgetSetSensitive (fpropLDEntry fprop') False
entrySetText (fpropLDEntry fprop') "( Not a symlink )"
cbox <- dialogGetActionArea dialog
_ <- dialogAddButton dialog "Ok" (ResponseUser 0)
_ <- dialogAddButton dialog "Cancel" (ResponseUser 1)
boxPackStart (castToBox cbox) grid PackNatural 5
widgetShowAll dialog
_ <- dialogRun dialog
-- make sure our grid does not get destroyed
containerRemove (castToBox cbox) grid
widgetDestroy dialog
return ()
showFilePropertyDialog _ _ _ = return ()

View File

@@ -16,6 +16,7 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyGUI where module HSFM.GUI.Gtk.MyGUI where
@@ -26,6 +27,7 @@ import Control.Concurrent.STM
newTVarIO newTVarIO
) )
import Graphics.UI.Gtk import Graphics.UI.Gtk
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import Paths_hsfm import Paths_hsfm
( (
@@ -46,6 +48,7 @@ createMyGUI = do
let settings' = MkFMSettings False True 24 let settings' = MkFMSettings False True 24
settings <- newTVarIO settings' settings <- newTVarIO settings'
operationBuffer <- newTVarIO None
builder <- builderNew builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml" builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
@@ -53,64 +56,38 @@ createMyGUI = do
-- get the pre-defined gui widgets -- get the pre-defined gui widgets
rootWin <- builderGetObject builder castToWindow rootWin <- builderGetObject builder castToWindow
"rootWin" "rootWin"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
menubarFileQuit <- builderGetObject builder castToImageMenuItem menubarFileQuit <- builderGetObject builder castToImageMenuItem
"menubarFileQuit" "menubarFileQuit"
menubarFileOpen <- builderGetObject builder castToImageMenuItem
"menubarFileOpen"
menubarFileExecute <- builderGetObject builder castToImageMenuItem
"menubarFileExecute"
menubarFileNew <- builderGetObject builder castToImageMenuItem
"menubarFileNew"
menubarEditCut <- builderGetObject builder castToImageMenuItem
"menubarEditCut"
menubarEditCopy <- builderGetObject builder castToImageMenuItem
"menubarEditCopy"
menubarEditRename <- builderGetObject builder castToImageMenuItem
"menubarEditRename"
menubarEditPaste <- builderGetObject builder castToImageMenuItem
"menubarEditPaste"
menubarEditDelete <- builderGetObject builder castToImageMenuItem
"menubarEditDelete"
menubarHelpAbout <- builderGetObject builder castToImageMenuItem menubarHelpAbout <- builderGetObject builder castToImageMenuItem
"menubarHelpAbout" "menubarHelpAbout"
urlBar <- builderGetObject builder castToEntry
"urlBar"
statusBar <- builderGetObject builder castToStatusbar statusBar <- builderGetObject builder castToStatusbar
"statusBar" "statusBar"
clearStatusBar <- builderGetObject builder castToButton clearStatusBar <- builderGetObject builder castToButton
"clearStatusBar" "clearStatusBar"
rcMenu <- builderGetObject builder castToMenu fpropGrid <- builderGetObject builder castToGrid
"rcMenu" "fpropGrid"
rcFileOpen <- builderGetObject builder castToImageMenuItem fpropFnEntry <- builderGetObject builder castToEntry
"rcFileOpen" "fpropFnEntry"
rcFileExecute <- builderGetObject builder castToImageMenuItem fpropLocEntry <- builderGetObject builder castToEntry
"rcFileExecute" "fpropLocEntry"
rcFileNew <- builderGetObject builder castToImageMenuItem fpropTsEntry <- builderGetObject builder castToEntry
"rcFileNew" "fpropTsEntry"
rcFileCut <- builderGetObject builder castToImageMenuItem fpropModEntry <- builderGetObject builder castToEntry
"rcFileCut" "fpropModEntry"
rcFileCopy <- builderGetObject builder castToImageMenuItem fpropAcEntry <- builderGetObject builder castToEntry
"rcFileCopy" "fpropAcEntry"
rcFileRename <- builderGetObject builder castToImageMenuItem fpropFTEntry <- builderGetObject builder castToEntry
"rcFileRename" "fpropFTEntry"
rcFilePaste <- builderGetObject builder castToImageMenuItem fpropPermEntry <- builderGetObject builder castToEntry
"rcFilePaste" "fpropPermEntry"
rcFileDelete <- builderGetObject builder castToImageMenuItem fpropLDEntry <- builderGetObject builder castToEntry
"rcFileDelete" "fpropLDEntry"
upViewB <- builderGetObject builder castToButton notebook <- builderGetObject builder castToNotebook
"upViewB" "notebook"
homeViewB <- builderGetObject builder castToButton
"homeViewB"
refreshViewB <- builderGetObject builder castToButton
"refreshViewB"
menubarViewTree <- builderGetObject builder castToImageMenuItem
"menubarViewTree"
menubarViewIcon <- builderGetObject builder castToImageMenuItem
"menubarViewIcon"
-- construct the gui object -- construct the gui object
let menubar = MkMenuBar {..}
let fprop = MkFilePropertyGrid {..}
let mygui = MkMyGUI {..} let mygui = MkMyGUI {..}
-- sets the default icon -- sets the default icon

View File

@@ -16,8 +16,6 @@ along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
--} --}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
module HSFM.GUI.Gtk.MyView where module HSFM.GUI.Gtk.MyView where
@@ -48,36 +46,48 @@ import Data.Maybe
catMaybes catMaybes
, fromJust , fromJust
) )
import HSFM.FileSystem.Errors
(
canOpenDirectory
)
import Graphics.UI.Gtk import Graphics.UI.Gtk
import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setCallbacks) import {-# SOURCE #-} HSFM.GUI.Gtk.Callbacks (setViewCallbacks)
import HPath import HPath
( (
Path Path
, Abs , Abs
) )
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.FileOperations
import HSFM.FileSystem.FileType import HSFM.FileSystem.FileType
import HSFM.GUI.Glib.GlibString() import HSFM.GUI.Glib.GlibString()
import HSFM.GUI.Gtk.Data import HSFM.GUI.Gtk.Data
import HSFM.GUI.Gtk.Icons import HSFM.GUI.Gtk.Icons
import HSFM.GUI.Gtk.Utils import HSFM.GUI.Gtk.Utils
import HSFM.Utils.IO import HSFM.Utils.IO
import Paths_hsfm
(
getDataFileName
)
import Prelude hiding(readFile) import Prelude hiding(readFile)
import System.INotify.ByteString import System.INotify
( (
addWatch addWatch
, initINotify , initINotify
, killINotify , killINotify
, EventVariety(..) , EventVariety(..)
) )
import System.IO.Error
(
tryIOError
)
-- |Creates a new tab with its own view and refreshes the view.
newTab :: MyGUI -> IO FMView -> Path Abs -> IO MyView
newTab mygui iofmv path = do
myview <- createMyView mygui iofmv
_ <- notebookAppendPage (notebook mygui) (viewBox myview)
(maybe (P.fromAbs path) P.fromRel $ P.basename path)
refreshView mygui myview (Just path)
return myview
-- |Constructs the initial MyView object with a few dummy models. -- |Constructs the initial MyView object with a few dummy models.
-- It also initializes the callbacks. -- It also initializes the callbacks.
@@ -85,9 +95,11 @@ createMyView :: MyGUI
-> IO FMView -> IO FMView
-> IO MyView -> IO MyView
createMyView mygui iofmv = do createMyView mygui iofmv = do
operationBuffer <- newTVarIO None
inotify <- newEmptyMVar inotify <- newEmptyMVar
history <- newTVarIO ([],[])
builder <- builderNew
builderAddFromFile builder =<< getDataFileName "data/Gtk/builder.xml"
-- create dummy models, so we don't have to use MVar -- create dummy models, so we don't have to use MVar
rawModel <- newTVarIO =<< listStoreNew [] rawModel <- newTVarIO =<< listStoreNew []
@@ -99,14 +111,56 @@ createMyView mygui iofmv = do
view' <- iofmv view' <- iofmv
view <- newTVarIO view' view <- newTVarIO view'
urlBar <- builderGetObject builder castToEntry
"urlBar"
rcMenu <- builderGetObject builder castToMenu
"rcMenu"
rcFileOpen <- builderGetObject builder castToImageMenuItem
"rcFileOpen"
rcFileExecute <- builderGetObject builder castToImageMenuItem
"rcFileExecute"
rcFileNewRegFile <- builderGetObject builder castToImageMenuItem
"rcFileNewRegFile"
rcFileNewDir <- builderGetObject builder castToImageMenuItem
"rcFileNewDir"
rcFileCut <- builderGetObject builder castToImageMenuItem
"rcFileCut"
rcFileCopy <- builderGetObject builder castToImageMenuItem
"rcFileCopy"
rcFileRename <- builderGetObject builder castToImageMenuItem
"rcFileRename"
rcFilePaste <- builderGetObject builder castToImageMenuItem
"rcFilePaste"
rcFileDelete <- builderGetObject builder castToImageMenuItem
"rcFileDelete"
rcFileProperty <- builderGetObject builder castToImageMenuItem
"rcFileProperty"
rcFileIconView <- builderGetObject builder castToImageMenuItem
"rcFileIconView"
rcFileTreeView <- builderGetObject builder castToImageMenuItem
"rcFileTreeView"
upViewB <- builderGetObject builder castToButton
"upViewB"
homeViewB <- builderGetObject builder castToButton
"homeViewB"
refreshViewB <- builderGetObject builder castToButton
"refreshViewB"
scroll <- builderGetObject builder castToScrolledWindow
"mainScroll"
viewBox <- builderGetObject builder castToBox
"viewBox"
let rcmenu = MkRightClickMenu {..}
let myview = MkMyView {..} let myview = MkMyView {..}
-- set the bindings -- set the bindings
setCallbacks mygui myview setViewCallbacks mygui myview
-- add the treeview to the scroll container -- add the treeview to the scroll container
let oview = fmViewToContainer view' let oview = fmViewToContainer view'
containerAdd (scroll mygui) oview containerAdd scroll oview
widgetShowAll viewBox
return myview return myview
@@ -115,22 +169,41 @@ createMyView mygui iofmv = do
-- io action returns. -- io action returns.
switchView :: MyGUI -> MyView -> IO FMView -> IO () switchView :: MyGUI -> MyView -> IO FMView -> IO ()
switchView mygui myview iofmv = do switchView mygui myview iofmv = do
cwd <- getCurrentDir myview
oldpage <- destroyView mygui myview
-- create new view and tab page where the previous one was
nview <- createMyView mygui iofmv
newpage <- notebookInsertPage (notebook mygui) (viewBox nview)
(maybe (P.fromAbs $ path cwd) P.fromRel
$ P.basename . path $ cwd) oldpage
notebookSetCurrentPage (notebook mygui) newpage
refreshView' mygui nview cwd
-- |Destroys the current view by disconnecting the watcher
-- and destroying the active FMView container.
--
-- Everything that needs to be done in order to forget about a
-- view needs to be done here.
--
-- Returns the page in the tab list this view corresponds to.
destroyView :: MyGUI -> MyView -> IO Int
destroyView mygui myview = do
-- disconnect watcher
mi <- tryTakeMVar (inotify myview)
for_ mi $ \i -> killINotify i
page <- notebookGetCurrentPage (notebook mygui)
-- destroy old view and tab page
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
let oview = fmViewToContainer view' widgetDestroy (fmViewToContainer view')
notebookRemovePage (notebook mygui) page
widgetDestroy oview return page
nview' <- iofmv
let nview = fmViewToContainer nview'
writeTVarIO (view myview) nview'
setCallbacks mygui myview
containerAdd (scroll mygui) nview
widgetShow nview
refreshView mygui myview Nothing
-- |Createss an IconView. -- |Createss an IconView.
@@ -156,6 +229,13 @@ createTreeView = do
tvs <- treeViewGetSelection treeView tvs <- treeViewGetSelection treeView
treeSelectionSetMode tvs SelectionMultiple treeSelectionSetMode tvs SelectionMultiple
-- set drag and drop
tl <- targetListNew
atom <- atomNew ("HSFM" :: String)
targetListAdd tl atom [TargetSameApp] 0
treeViewEnableModelDragDest treeView tl [ActionCopy]
treeViewEnableModelDragSource treeView [Button1] tl [ActionCopy]
-- create final tree model columns -- create final tree model columns
renderTxt <- cellRendererTextNew renderTxt <- cellRendererTextNew
renderPix <- cellRendererPixbufNew renderPix <- cellRendererPixbufNew
@@ -212,16 +292,10 @@ refreshView :: MyGUI
refreshView mygui myview mfp = refreshView mygui myview mfp =
case mfp of case mfp of
Just fp -> do Just fp -> do
-- readFileWithFileInfo can just outright fail... canopen <- canOpenDirectory fp
ecdir <- tryIOError (readFile getFileInfo fp) if canopen
case ecdir of then refreshView' mygui myview =<< readFile getFileInfo fp
Right cdir -> else refreshView mygui myview =<< getAlternativeDir
-- ...or return an `AnchordFile` with a Failed constructor,
-- both of which need to be handled here
if (failed cdir)
then refreshView mygui myview =<< getAlternativeDir
else refreshView' mygui myview cdir
Left _ -> refreshView mygui myview =<< getAlternativeDir
Nothing -> refreshView mygui myview =<< getAlternativeDir Nothing -> refreshView mygui myview =<< getAlternativeDir
where where
getAlternativeDir = do getAlternativeDir = do
@@ -229,7 +303,7 @@ refreshView mygui myview mfp =
Item) Item)
case ecd of case ecd of
Right dir -> return (Just $ path dir) Right dir -> return (Just $ path dir)
Left _ -> return (P.parseAbs "/") Left _ -> return (P.parseAbs P.pathSeparator')
-- |Refreshes the View based on the given directory. -- |Refreshes the View based on the given directory.
@@ -240,14 +314,16 @@ refreshView' :: MyGUI
-> MyView -> MyView
-> Item -> Item
-> IO () -> IO ()
refreshView' mygui myview dt@(DirOrSym _) = do refreshView' mygui myview SymLink { sdest = d@Dir{} } =
newRawModel <- fileListStore dt myview refreshView' mygui myview d
refreshView' mygui myview item@Dir{} = do
newRawModel <- fileListStore item myview
writeTVarIO (rawModel myview) newRawModel writeTVarIO (rawModel myview) newRawModel
view' <- readTVarIO $ view myview view' <- readTVarIO $ view myview
_ <- tryTakeMVar (cwd myview) _ <- tryTakeMVar (cwd myview)
putMVar (cwd myview) dt putMVar (cwd myview) item
-- get selected items -- get selected items
tps <- getSelectedTreePaths mygui myview tps <- getSelectedTreePaths mygui myview
@@ -255,6 +331,12 @@ refreshView' mygui myview dt@(DirOrSym _) = do
constructView mygui myview constructView mygui myview
-- set notebook tab label
page <- notebookGetCurrentPage (notebook mygui)
child <- fromJust <$> notebookGetNthPage (notebook mygui) page
notebookSetTabLabelText (notebook mygui) child
(maybe (P.fromAbs $ path item) P.fromRel $ P.basename . path $ item)
-- reselect selected items -- reselect selected items
-- TODO: not implemented for icon view yet -- TODO: not implemented for icon view yet
case view' of case view' of
@@ -299,7 +381,7 @@ constructView mygui myview = do
cdirp <- path <$> getCurrentDir myview cdirp <- path <$> getCurrentDir myview
-- update urlBar -- update urlBar
entrySetText (urlBar mygui) (P.fromAbs cdirp) entrySetText (urlBar myview) (P.fromAbs cdirp)
rawModel' <- readTVarIO $ rawModel myview rawModel' <- readTVarIO $ rawModel myview

View File

@@ -67,24 +67,7 @@ getSelectedItems :: MyGUI
-> IO [Item] -> IO [Item]
getSelectedItems mygui myview = do getSelectedItems mygui myview = do
tps <- getSelectedTreePaths mygui myview tps <- getSelectedTreePaths mygui myview
getSelectedItems' mygui myview tps catMaybes <$> mapM (rawPathToItem myview) tps
getSelectedItems' :: MyGUI
-> MyView
-> [TreePath]
-> IO [Item]
getSelectedItems' _ myview tps = do
rawModel' <- readTVarIO $ rawModel myview
sortedModel' <- readTVarIO $ sortedModel myview
filteredModel' <- readTVarIO $ filteredModel myview
iters <- catMaybes <$> mapM (treeModelGetIter sortedModel') tps
forM iters $ \iter -> do
cIter' <- treeModelSortConvertIterToChildIter sortedModel' iter
cIter <- treeModelFilterConvertIterToChildIter filteredModel' cIter'
treeModelGetRow rawModel' cIter
-- |Carry out an action on the currently selected item. -- |Carry out an action on the currently selected item.
@@ -124,13 +107,14 @@ getFirstItem myview = do
-- |Reads the current directory from MyView. -- |Reads the current directory from MyView.
--
-- This reads the MVar and may block the main thread if it's
-- empty.
getCurrentDir :: MyView getCurrentDir :: MyView
-> IO Item -> IO Item
getCurrentDir myview = readMVar (cwd myview) getCurrentDir myview = readMVar (cwd myview)
-- |Push a message to the status bar. -- |Push a message to the status bar.
pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId) pushStatusBar :: MyGUI -> String -> IO (ContextId, MessageId)
pushStatusBar mygui str = do pushStatusBar mygui str = do
@@ -146,3 +130,37 @@ popStatusbar mygui = do
let sb = statusBar mygui let sb = statusBar mygui
cid <- statusbarGetContextId sb "FM Status" cid <- statusbarGetContextId sb "FM Status"
statusbarPop sb cid statusbarPop sb cid
-- |Turn a path on the rawModel into a path that we can
-- use at the outermost model layer.
rawPathToIter :: MyView -> TreePath -> IO (Maybe TreeIter)
rawPathToIter myview tp = do
fmodel <- readTVarIO (filteredModel myview)
smodel <- readTVarIO (sortedModel myview)
msiter <- treeModelGetIter smodel tp
forM msiter $ \siter -> do
cIter <- treeModelSortConvertIterToChildIter smodel siter
treeModelFilterConvertIterToChildIter fmodel cIter
-- |Turn a path on the rawModel into the corresponding item
-- that we can use at the outermost model layer.
rawPathToItem :: MyView -> TreePath -> IO (Maybe Item)
rawPathToItem myview tp = do
rawModel' <- readTVarIO $ rawModel myview
miter <- rawPathToIter myview tp
forM miter $ \iter -> treeModelGetRow rawModel' iter
-- |Makes sure the list is max 5. This is probably not very efficient
-- but we don't care, since it's a small list anyway.
addHistory :: Eq a => a -> [a] -> [a]
addHistory i [] = [i]
addHistory i xs@(x:_)
| i == x = xs
| length xs == maxLength = i : take (maxLength - 1) xs
| otherwise = i : xs
where
maxLength = 10

View File

@@ -0,0 +1,110 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyDirRecursiveOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyDirRecursiveOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyDirRecursiveOverwrite" $ do
-- successes --
it "copyDirRecursiveOverwrite, all fine" $ do
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
removeDirIfExists $ specDir `ba` "outputDir"
it "copyDirRecursiveOverwrite, all fine and compare" $ do
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
(system $ "diff -r --no-dereference "
++ specDir' ++ "inputDir" ++ " "
++ specDir' ++ "outputDir")
`shouldReturn` ExitSuccess
removeDirIfExists $ specDir `ba` "outputDir"
it "copyDirRecursiveOverwrite, destination dir already exists" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExistsD")
-- posix failures --
it "copyDirRecursiveOverwrite, source directory does not exist" $
copyDirRecursiveOverwrite' (specDir `ba` "doesNotExist")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyDirRecursiveOverwrite, no write permission on output dir" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "noWritePerm/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, cannot open output dir" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, cannot open source dir" $
copyDirRecursiveOverwrite' (specDir `ba` "noPerms/inputDir")
(specDir `ba` "foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursiveOverwrite, destination already exists and is a file" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursiveOverwrite, wrong input (regular file)" $
copyDirRecursiveOverwrite' (specDir `ba` "wrongInput")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursiveOverwrite, wrong input (symlink to directory)" $
copyDirRecursiveOverwrite' (specDir `ba` "wrongInputSymL")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
-- custom failures
it "copyDirRecursiveOverwrite, destination in source" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "inputDir/foo")
`shouldThrow`
isDestinationInSource
it "copyDirRecursiveOverwrite, destination and source same directory" $
copyDirRecursiveOverwrite' (specDir `ba` "inputDir")
(specDir `ba` "inputDir")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,112 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyDirRecursiveSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyDirRecursiveSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyDirRecursive" $ do
-- successes --
it "copyDirRecursive, all fine" $ do
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
removeDirIfExists (specDir `ba` "outputDir")
it "copyDirRecursive, all fine and compare" $ do
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "outputDir")
(system $ "diff -r --no-dereference "
++ specDir' ++ "inputDir" ++ " "
++ specDir' ++ "outputDir")
`shouldReturn` ExitSuccess
removeDirIfExists (specDir `ba` "outputDir")
-- posix failures --
it "copyDirRecursive, source directory does not exist" $
copyDirRecursive' (specDir `ba` "doesNotExist")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyDirRecursive, no write permission on output dir" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "noWritePerm/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, cannot open output dir" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, cannot open source dir" $
copyDirRecursive' (specDir `ba` "noPerms/inputDir")
(specDir `ba` "foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyDirRecursive, destination dir already exists" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyDirRecursive, destination already exists and is a file" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyDirRecursive, wrong input (regular file)" $
copyDirRecursive' (specDir `ba` "wrongInput")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyDirRecursive, wrong input (symlink to directory)" $
copyDirRecursive' (specDir `ba` "wrongInputSymL")
(specDir `ba` "outputDir")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
-- custom failures
it "copyDirRecursive, destination in source" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "inputDir/foo")
`shouldThrow`
isDestinationInSource
it "copyDirRecursive, destination and source same directory" $
copyDirRecursive' (specDir `ba` "inputDir")
(specDir `ba` "inputDir")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,109 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyFileOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyFileOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyFileOverwrite" $ do
-- successes --
it "copyFileOverwrite, everything clear" $ do
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
removeFileIfExists (specDir `ba` "outputFile")
it "copyFileOverwrite, output file already exists, all clear" $ do
copyFile' (specDir `ba` "alreadyExists") (specDir `ba` "alreadyExists.bak")
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExists")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "alreadyExists")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "alreadyExists")
copyFile' (specDir `ba` "alreadyExists.bak") (specDir `ba` "alreadyExists")
removeFileIfExists (specDir `ba` "alreadyExists.bak")
it "copyFileOverwrite, and compare" $ do
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "outputFile")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "outputFile")
-- posix failures --
it "copyFileOverwrite, input file does not exist" $
copyFileOverwrite' (specDir `ba` "noSuchFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyFileOverwrite, no permission to write to output directory" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "outputDirNoWrite/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, cannot open output directory" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "noPerms/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, cannot open source directory" $
copyFileOverwrite' (specDir `ba` "noPerms/inputFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFileOverwrite, wrong input type (symlink)" $
copyFileOverwrite' (specDir `ba` "inputFileSymL")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "copyFileOverwrite, wrong input type (directory)" $
copyFileOverwrite' (specDir `ba` "wrongInput")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyFileOverwrite, output file already exists and is a dir" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
-- custom failures --
it "copyFileOverwrite, output and input are same file" $
copyFileOverwrite' (specDir `ba` "inputFile")
(specDir `ba` "inputFile")
`shouldThrow` isSameFile

View File

@@ -0,0 +1,105 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CopyFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import System.Exit
import System.Process
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/copyFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.copyFile" $ do
-- successes --
it "copyFile, everything clear" $ do
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
removeFileIfExists (specDir `ba` "outputFile")
it "copyFile, and compare" $ do
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputFile")
(system $ "cmp -s " ++ specDir' ++ "inputFile" ++ " "
++ specDir' ++ "outputFile")
`shouldReturn` ExitSuccess
removeFileIfExists (specDir `ba` "outputFile")
-- posix failures --
it "copyFile, input file does not exist" $
copyFile' (specDir `ba` "noSuchFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "copyFile, no permission to write to output directory" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "outputDirNoWrite/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, cannot open output directory" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "noPerms/outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, cannot open source directory" $
copyFile' (specDir `ba` "noPerms/inputFile")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "copyFile, wrong input type (symlink)" $
copyFile' (specDir `ba` "inputFileSymL")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "copyFile, wrong input type (directory)" $
copyFile' (specDir `ba` "wrongInput")
(specDir `ba` "outputFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "copyFile, output file already exists" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "copyFile, output file already exists and is a dir" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
-- custom failures --
it "copyFile, output and input are same file" $
copyFile' (specDir `ba` "inputFile")
(specDir `ba` "inputFile")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,54 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CreateDirSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/createDirSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.createDir" $ do
-- successes --
it "createDir, all fine" $ do
createDir' (specDir `ba` "newDir")
removeDirIfExists (specDir `ba` "newDir")
-- posix failures --
it "createDir, can't write to output directory" $
createDir' (specDir `ba` "noWritePerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createDir, can't open output directory" $
createDir' (specDir `ba` "noPerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createDir, destination directory already exists" $
createDir' (specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)

View File

@@ -0,0 +1,54 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.CreateRegularFileSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/createRegularFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.createRegularFile" $ do
-- successes --
it "createRegularFile, all fine" $ do
createRegularFile' (specDir `ba` "newDir")
removeFileIfExists (specDir `ba` "newDir")
-- posix failures --
it "createRegularFile, can't write to destination directory" $
createRegularFile' (specDir `ba` "noWritePerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createRegularFile, can't write to destination directory" $
createRegularFile' (specDir `ba` "noPerms/newDir")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "createRegularFile, destination file already exists" $
createRegularFile' (specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)

View File

@@ -0,0 +1,97 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteDirRecursiveSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteDirRecursiveSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteDirRecursive" $ do
-- successes --
it "deleteDirRecursive, empty directory, all fine" $ do
createDir' (specDir `ba` "testDir")
deleteDirRecursive' (specDir `ba` "testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDirRecursive, empty directory with null permissions, all fine" $ do
createDir' (specDir `ba` "noPerms/testDir")
noPerms (specDir `ba` "noPerms/testDir")
deleteDirRecursive' (specDir `ba` "noPerms/testDir")
it "deleteDirRecursive, non-empty directory, all fine" $ do
createDir' (specDir `ba` "nonEmpty")
createDir' (specDir `ba` "nonEmpty/dir1")
createDir' (specDir `ba` "nonEmpty/dir2")
createDir' (specDir `ba` "nonEmpty/dir2/dir3")
createRegularFile' (specDir `ba` "nonEmpty/file1")
createRegularFile' (specDir `ba` "nonEmpty/dir1/file2")
deleteDirRecursive' (specDir `ba` "nonEmpty")
getSymbolicLinkStatus (specDir `ba` "nonEmpty")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteDirRecursive, can't open parent directory" $ do
createDir' (specDir `ba` "noPerms/foo")
noPerms (specDir `ba` "noPerms")
(deleteDirRecursive' (specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
>> normalDirPerms (specDir `ba` "noPerms")
>> deleteDir' (specDir `ba` "noPerms/foo")
it "deleteDirRecursive, can't write to parent directory" $ do
createDir' (specDir `ba` "noWritable/foo")
noWritableDirPerms (specDir `ba` "noWritable")
(deleteDirRecursive' (specDir `ba` "noWritable/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
normalDirPerms (specDir `ba` "noWritable")
deleteDir' (specDir `ba` "noWritable/foo")
it "deleteDirRecursive, wrong file type (symlink to directory)" $
deleteDirRecursive' (specDir `ba` "dirSym")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDirRecursive, wrong file type (regular file)" $
deleteDirRecursive' (specDir `ba` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDirRecursive, directory does not exist" $
deleteDirRecursive' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)

View File

@@ -0,0 +1,94 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteDirSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteDirSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteDir" $ do
-- successes --
it "deleteDir, empty directory, all fine" $ do
createDir' (specDir `ba` "testDir")
deleteDir' (specDir `ba` "testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDir, directory with null permissions, all fine" $ do
createDir' (specDir `ba` "noPerms/testDir")
noPerms (specDir `ba` "noPerms/testDir")
deleteDir' (specDir `ba` "noPerms/testDir")
getSymbolicLinkStatus (specDir `ba` "testDir")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteDir, wrong file type (symlink to directory)" $
deleteDir' (specDir `ba` "dirSym")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDir, wrong file type (regular file)" $
deleteDir' (specDir `ba` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteDir, directory does not exist" $
deleteDir' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteDir, directory not empty" $
deleteDir' (specDir `ba` "dir")
`shouldThrow`
(\e -> ioeGetErrorType e == UnsatisfiedConstraints)
it "deleteDir, can't open parent directory" $ do
createDir' (specDir `ba` "noPerms/foo")
noPerms (specDir `ba` "noPerms")
(deleteDir' (specDir `ba` "noPerms/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
>> normalDirPerms (specDir `ba` "noPerms")
>> deleteDir' (specDir `ba` "noPerms/foo")
it "deleteDir, can't write to parent directory, still fine" $ do
createDir' (specDir `ba` "noWritable/foo")
noWritableDirPerms (specDir `ba` "noWritable")
(deleteDir' (specDir `ba` "noWritable/foo")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied))
normalDirPerms (specDir `ba` "noWritable")
deleteDir' (specDir `ba` "noWritable/foo")

View File

@@ -0,0 +1,69 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.DeleteFileSpec where
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Files.ByteString
(
getSymbolicLinkStatus
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/deleteFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.deleteFile" $ do
-- successes --
it "deleteFile, regular file, all fine" $ do
createRegularFile' (specDir `ba` "testFile")
deleteFile' (specDir `ba` "testFile")
getSymbolicLinkStatus (specDir `ba` "testFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteFile, symlink, all fine" $ do
recreateSymlink' (specDir `ba` "syml")
(specDir `ba` "testFile")
deleteFile' (specDir `ba` "testFile")
getSymbolicLinkStatus (specDir `ba` "testFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
-- posix failures --
it "deleteFile, wrong file type (directory)" $
deleteFile' (specDir `ba` "dir")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "deleteFile, file does not exist" $
deleteFile' (specDir `ba` "doesNotExist")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "deleteFile, can't read directory" $
deleteFile' (specDir `ba` "noPerms/blah")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

View File

@@ -0,0 +1,88 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.GetDirsFilesSpec where
import Data.List
(
sort
)
import Data.Maybe
(
fromJust
)
import qualified HPath as P
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import System.Posix.Env.ByteString
(
getEnv
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/getDirsFilesSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.getDirsFiles" $ do
-- successes --
it "getDirsFiles, all fine" $ do
pwd <- fromJust <$> getEnv "PWD" >>= P.parseAbs
expectedFiles <- mapM P.parseRel [(specDir `ba ` ".hidden")
,(specDir `ba ` "Lala")
,(specDir `ba ` "dir")
,(specDir `ba ` "dirsym")
,(specDir `ba ` "file")
,(specDir `ba ` "noPerms")
,(specDir `ba ` "syml")]
(fmap sort $ getDirsFiles' specDir)
`shouldReturn` fmap (pwd P.</>) expectedFiles
-- posix failures --
it "getDirsFiles, nonexistent directory" $
getDirsFiles' (specDir `ba ` "nothingHere")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "getDirsFiles, wrong file type (file)" $
getDirsFiles' (specDir `ba ` "file")
`shouldThrow`
(\e -> ioeGetErrorType e == InappropriateType)
it "getDirsFiles, wrong file type (symlink to file)" $
getDirsFiles' (specDir `ba ` "syml")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "getDirsFiles, wrong file type (symlink to dir)" $
getDirsFiles' (specDir `ba ` "dirsym")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "getDirsFiles, can't open directory" $
getDirsFiles' (specDir `ba ` "noPerms")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

View File

@@ -0,0 +1,70 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.GetFileTypeSpec where
import HSFM.FileSystem.FileOperations
import Test.Hspec
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/getFileTypeSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.getFileType" $ do
-- successes --
it "getFileType, regular file" $
getFileType' (specDir `ba` "regularfile")
`shouldReturn` RegularFile
it "getFileType, directory" $
getFileType' (specDir `ba` "directory")
`shouldReturn` Directory
it "getFileType, directory with null permissions" $
getFileType' (specDir `ba` "noPerms")
`shouldReturn` Directory
it "getFileType, symlink to file" $
getFileType' (specDir `ba` "symlink")
`shouldReturn` SymbolicLink
it "getFileType, symlink to directory" $
getFileType' (specDir `ba` "symlinkD")
`shouldReturn` SymbolicLink
it "getFileType, broken symlink" $
getFileType' (specDir `ba` "brokenSymlink")
`shouldReturn` SymbolicLink
-- posix failures --
it "getFileType, file does not exist" $
getFileType' (specDir `ba` "nothingHere")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "getFileType, can't open directory" $
getFileType' (specDir `ba` "noPerms/forz")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)

View File

@@ -0,0 +1,93 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.MoveFileOverwriteSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/moveFileOverwriteSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.moveFileOverwrite" $ do
-- successes --
it "moveFileOverwrite, all fine" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
it "moveFileOverwrite, all fine" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "dir/movedFile")
it "moveFileOverwrite, all fine on symlink" $
moveFileOverwrite' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
it "moveFileOverwrite, all fine on directory" $
moveFileOverwrite' (specDir `ba` "dir")
(specDir `ba` "movedFile")
it "moveFileOverwrite, destination file already exists" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
-- posix failures --
it "moveFileOverwrite, source file does not exist" $
moveFileOverwrite' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "moveFileOverwrite, can't write to destination directory" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFileOverwrite, can't open destination directory" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFileOverwrite, can't open source directory" $
moveFileOverwrite' (specDir `ba` "noPerms/myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "moveFileOverwrite, move from file to dir" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "moveFileOverwrite, source and dest are same file" $
moveFileOverwrite' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.MoveFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/moveFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.moveFile" $ do
-- successes --
it "moveFile, all fine" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
it "moveFile, all fine" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "dir/movedFile")
it "moveFile, all fine on symlink" $
moveFile' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
it "moveFile, all fine on directory" $
moveFile' (specDir `ba` "dir")
(specDir `ba` "movedFile")
-- posix failures --
it "moveFile, source file does not exist" $
moveFile' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "moveFile, can't write to destination directory" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFile, can't open destination directory" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "moveFile, can't open source directory" $
moveFile' (specDir `ba` "noPerms/myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "moveFile, destination file already exists" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
isFileDoesExist
it "moveFile, move from file to dir" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "moveFile, source and dest are same file" $
moveFile' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.RecreateSymlinkSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/recreateSymlinkSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.recreateSymlink" $ do
-- successes --
it "recreateSymLink, all fine" $ do
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "movedFile")
removeFileIfExists (specDir `ba` "movedFile")
it "recreateSymLink, all fine" $ do
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "dir/movedFile")
removeFileIfExists (specDir `ba` "dir/movedFile")
-- posix failures --
it "recreateSymLink, wrong input type (file)" $
recreateSymlink' (specDir `ba` "myFile")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "recreateSymLink, wrong input type (directory)" $
recreateSymlink' (specDir `ba` "dir")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == InvalidArgument)
it "recreateSymLink, can't write to destination directory" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "noWritePerm/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, can't open destination directory" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "noPerms/movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, can't open source directory" $
recreateSymlink' (specDir `ba` "noPerms/myFileL")
(specDir `ba` "movedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "recreateSymLink, destination file already exists" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "alreadyExists")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
it "recreateSymLink, destination already exists and is a dir" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
(\e -> ioeGetErrorType e == AlreadyExists)
-- custom failures --
it "recreateSymLink, source and destination are the same file" $
recreateSymlink' (specDir `ba` "myFileL")
(specDir `ba` "myFileL")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,95 @@
{-# LANGUAGE OverloadedStrings #-}
module FileSystem.FileOperations.RenameFileSpec where
import Test.Hspec
import HSFM.FileSystem.Errors
import System.IO.Error
(
ioeGetErrorType
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Utils
import qualified Data.ByteString as BS
import Data.ByteString.UTF8 (toString)
ba :: BS.ByteString -> BS.ByteString -> BS.ByteString
ba = BS.append
specDir :: BS.ByteString
specDir = "test/FileSystem/FileOperations/renameFileSpec/"
specDir' :: String
specDir' = toString specDir
spec :: Spec
spec =
describe "HSFM.FileSystem.FileOperations.renameFile" $ do
-- successes --
it "renameFile, all fine" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "renamedFile")
it "renameFile, all fine" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "dir/renamedFile")
it "renameFile, all fine on symlink" $
renameFile' (specDir `ba` "myFileL")
(specDir `ba` "renamedFile")
it "renameFile, all fine on directory" $
renameFile' (specDir `ba` "dir")
(specDir `ba` "renamedFile")
-- posix failures --
it "renameFile, source file does not exist" $
renameFile' (specDir `ba` "fileDoesNotExist")
(specDir `ba` "renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == NoSuchThing)
it "renameFile, can't write to output directory" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "noWritePerm/renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "renameFile, can't open output directory" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "noPerms/renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
it "renameFile, can't open source directory" $
renameFile' (specDir `ba` "noPerms/myFile")
(specDir `ba` "renamedFile")
`shouldThrow`
(\e -> ioeGetErrorType e == PermissionDenied)
-- custom failures --
it "renameFile, destination file already exists" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExists")
`shouldThrow`
isFileDoesExist
it "renameFile, move from file to dir" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "alreadyExistsD")
`shouldThrow`
isDirDoesExist
it "renameFile, source and dest are same file" $
renameFile' (specDir `ba` "myFile")
(specDir `ba` "myFile")
`shouldThrow`
isSameFile

View File

@@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

View File

@@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

View File

@@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

View File

@@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

View File

@@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

View File

@@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

View File

@@ -0,0 +1 @@
inputDir/

View File

@@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

View File

@@ -0,0 +1 @@
dadasasddas

View File

@@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

View File

@@ -0,0 +1,8 @@
dadasasddas
sda
!!1
sda
11

View File

@@ -0,0 +1,4 @@
dadasasddas
das
sda
sda

View File

@@ -0,0 +1 @@
inputDir/

View File

@@ -0,0 +1,16 @@
adaöölsdaöl
dsalö
ölsda
ääödsf
äsdfä
öä453
öä
435
ä45343
5
453
453453453
das
asd
das

View File

@@ -0,0 +1,4 @@
abc
def
dsadasdsa

View File

@@ -0,0 +1 @@
inputFile

View File

@@ -0,0 +1,2 @@
abc
def

View File

@@ -0,0 +1 @@
inputFile

View File

@@ -0,0 +1 @@
dir

View File

@@ -0,0 +1 @@
dir

View File

@@ -0,0 +1 @@
foo

Some files were not shown because too many files have changed in this diff Show More